diff options
87 files changed, 6971 insertions, 3494 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 000000000..62660e298 --- /dev/null +++ b/.gitignore @@ -0,0 +1,65 @@ +*.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 @@ -1,10 +1,11 @@ -Notes on the Free Translation Project -************************************* +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 will gradually become able to speak many languages. -A few packages already provide translations for their messages. +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, @@ -15,15 +16,15 @@ 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 at translations should contact the appropriate team. +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. -Quick configuration advice -========================== +1.1 Quick configuration advice +============================== If you want to exploit the full power of internationalization, you should configure it using @@ -45,8 +46,8 @@ to change to GNU `gettext' as soon as possible. you have installed a recent copy of the GNU gettext package with the included `libintl'. -INSTALL Matters -=============== +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 @@ -55,27 +56,27 @@ 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 GNU `gettext' own -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: +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 +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 be not what is 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 +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 @@ -86,7 +87,7 @@ 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 have usually many `po/LL.po' files, where + 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 @@ -95,8 +96,8 @@ 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. -Using This Package -================== +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 @@ -117,8 +118,8 @@ country code serves to distinguish the dialects. 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 country by running the command -`locale -a | grep '^LL''. +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 @@ -144,8 +145,8 @@ 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. -Translating Teams -================= +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 @@ -171,565 +172,897 @@ 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 skill are praised more than -programming skill, here. +the terminology in use. Proven linguistic skills are praised more than +programming skills, here. -Available Packages -================== +1.5 Available Packages +====================== Languages are not equally supported in all packages. The following -matrix shows the current state of internationalization, as of January -2004. The matrix shows, in regard of each package, for which languages +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 da de el en en_GB eo es + Ready PO files af am ar az be bg bs ca cs cy da de el en en_GB eo +----------------------------------------------------+ - a2ps | [] [] [] [] | - aegis | () | - ant-phone | () | - anubis | | + GNUnet | [] | + a2ps | [] [] [] [] [] | + aegis | () | + ant-phone | () | + anubis | [] | ap-utils | | - aspell | [] | - bash | [] [] [] [] | - batchelor | | - bfd | [] [] | - binutils | [] [] | - bison | [] [] [] | - bluez-pin | [] [] [] | - clisp | | - clisp | [] [] [] | - console-tools | [] [] | - coreutils | [] [] [] [] | - cpio | [] [] [] | - darkstat | [] () [] | - diffutils | [] [] [] [] [] [] [] | - e2fsprogs | [] [] [] | - enscript | [] [] [] [] | - error | [] [] [] [] [] | - fetchmail | [] () [] [] [] [] | - fileutils | [] [] [] | - findutils | [] [] [] [] [] [] [] | - flex | [] [] [] [] | - fslint | | - gas | [] | - gawk | [] [] [] [] | - gbiff | [] | + 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 | [] [] [] [] [] | - gettext-examples | [] [] [] [] | - gettext-runtime | [] [] [] [] [] | - gettext-tools | [] [] [] | - gimp-print | [] [] [] [] [] | - gliv | | - glunarclock | [] [] | - gnubiff | [] | - gnucash | [] () [] [] | - gnucash-glossary | [] () [] | - gnupg | [] () [] [] [] [] | - gpe-aerial | [] | - gpe-beam | [] [] | - gpe-calendar | [] [] | - gpe-clock | [] [] | - gpe-conf | [] [] | - gpe-contacts | [] [] | + 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-sketchbook | [] [] | - gpe-su | [] [] | - gpe-taskmanager | [] [] | + gpe-login | [] [] | + gpe-ownerinfo | [] [] | + gpe-package | | + gpe-sketchbook | [] [] | + gpe-su | [] [] | + gpe-taskmanager | [] [] | gpe-timesheet | [] | - gpe-today | [] [] | - gpe-todo | [] [] | - gphoto2 | [] [] [] [] | - gprof | [] [] [] | - gpsdrive | () () () | - gramadoir | [] | - grep | [] [] [] [] [] [] | - gretl | [] | - gtick | [] () | - hello | [] [] [] [] [] [] | - id-utils | [] [] | - indent | [] [] [] [] | - iso_3166 | [] [] [] [] [] [] [] [] [] [] | - iso_3166_1 | [] [] [] [] [] [] | + 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_3166_3 | [] | - iso_4217 | [] [] [] [] | - iso_639 | | - jpilot | [] [] [] | + iso_4217 | [] | + iso_639 | [] [] | + jpilot | [] | jtag | | - jwhois | [] | - kbd | [] [] [] [] [] | - latrine | () | - ld | [] [] | - libc | [] [] [] [] [] [] | - libgpewidget | [] [] | - libiconv | [] [] [] [] [] | - lifelines | [] () | - lilypond | [] | + 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 | | - lingoteach_lessons | () () | - lynx | [] [] [] [] | - m4 | [] [] [] [] | - mailutils | [] [] | - make | [] [] [] | - man-db | [] () [] [] () | - minicom | [] [] [] | - mysecretdiary | [] [] [] | - nano | [] () [] [] [] | - nano_1_0 | [] () [] [] [] | - opcodes | [] | - parted | [] [] [] [] [] | - ptx | [] [] [] [] [] | + lynx | [] [] [] [] | + m4 | [] [] [] [] | + mailutils | [] | + make | [] [] | + man-db | [] () [] [] | + minicom | [] [] [] | + mysecretdiary | [] [] | + nano | [] [] [] | + nano_1_0 | [] () [] [] | + opcodes | [] | + parted | | + pilot-qof | [] | + psmisc | [] | + pwdutils | | python | | - radius | [] | - recode | [] [] [] [] [] [] [] | - rpm | [] [] | + qof | | + radius | [] | + recode | [] [] [] [] [] [] | + rpm | [] [] | screem | | - scrollkeeper | [] [] [] [] [] [] | - sed | [] [] [] [] [] [] | - sh-utils | [] [] [] | - shared-mime-info | | - sharutils | [] [] [] [] [] [] | - silky | () | - skencil | [] () [] | - sketch | [] () [] | - soundtracker | [] [] [] | - sp | [] | - tar | [] [] [] [] | - texinfo | [] [] [] | - textutils | [] [] [] [] | - tin | () () | - tp-robot | | - tuxpaint | [] [] [] [] [] [] [] | + 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 | [] [] [] [] | - xfree86_xkb_xml | [] [] | - xpad | [] | + util-linux | [] [] [] [] | + vorbis-tools | [] [] [] [] | + wastesedge | () | + wdiff | [] [] [] [] | + wget | [] [] | + xchat | [] [] [] [] [] [] | + xkeyboard-config | | + xpad | [] [] | +----------------------------------------------------+ - af am ar az be bg bs ca cs da de el en en_GB eo es - 4 0 0 1 9 4 1 40 41 60 78 17 1 5 13 68 - - et eu fa fi fr ga gl he hr hu id is it ja ko lg + 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 +-------------------------------------------------+ - a2ps | [] [] [] () () | - aegis | | - ant-phone | [] | - anubis | [] | - ap-utils | [] | - aspell | [] [] | - bash | [] [] | - batchelor | [] [] | - bfd | [] | - binutils | [] [] | - bison | [] [] [] [] | - bluez-pin | [] [] [] [] [] | - clisp | | - clisp | [] | + 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 | [] [] [] [] | - darkstat | () [] [] [] | - diffutils | [] [] [] [] [] [] [] | - e2fsprogs | | - enscript | [] [] | - error | [] [] [] [] | - fetchmail | [] | - fileutils | [] [] [] [] [] [] | - findutils | [] [] [] [] [] [] [] [] [] [] [] | - flex | [] [] [] | - fslint | [] | - gas | [] | - gawk | [] [] [] | - gbiff | [] | - gcal | [] | - gcc | [] | - gettext | [] [] [] | - gettext-examples | [] [] | - gettext-runtime | [] [] [] [] [] | - gettext-tools | [] [] [] | - gimp-print | [] [] | - gliv | () | - glunarclock | [] [] [] [] | - gnubiff | [] | - gnucash | () [] | - gnucash-glossary | [] | - gnupg | [] [] [] [] [] [] [] | - gpe-aerial | [] | - gpe-beam | [] | - gpe-calendar | [] [] [] | - gpe-clock | [] | - gpe-conf | [] | - gpe-contacts | [] [] | - gpe-edit | [] [] | - gpe-go | [] | - gpe-login | [] [] | - gpe-ownerinfo | [] [] [] | - gpe-sketchbook | [] | - gpe-su | [] | - gpe-taskmanager | [] | - gpe-timesheet | [] [] [] | - gpe-today | [] [] | - gpe-todo | [] [] | - gphoto2 | [] [] [] | - gprof | [] [] | - gpsdrive | () () () | - gramadoir | [] [] | - grep | [] [] [] [] [] [] [] [] [] [] [] | - gretl | [] [] | - gtick | [] [] [] | - hello | [] [] [] [] [] [] [] [] [] [] [] [] [] | - id-utils | [] [] [] [] | - indent | [] [] [] [] [] [] [] [] [] | - iso_3166 | [] [] [] [] [] [] [] | - iso_3166_1 | [] [] [] [] [] | - iso_3166_2 | | - iso_3166_3 | | - iso_4217 | [] [] [] [] [] [] | - iso_639 | | - jpilot | [] () | - jtag | [] | - jwhois | [] [] [] [] | - kbd | [] | - latrine | [] | - ld | [] | - libc | [] [] [] [] [] [] | - libgpewidget | [] [] [] [] | - libiconv | [] [] [] [] [] [] [] [] [] | - lifelines | () | - lilypond | [] | - lingoteach | [] [] | - lingoteach_lessons | | - lynx | [] [] [] [] | - m4 | [] [] [] [] | + 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 | [] [] [] | - ptx | [] [] [] [] [] [] [] | + make | [] [] [] | + man-db | () | + minicom | [] | + mysecretdiary | [] | + nano | [] [] [] | + nano_1_0 | [] [] [] | + opcodes | [] | + parted | [] [] | + pilot-qof | | + psmisc | [] [] [] | + pwdutils | | python | | - radius | [] | - recode | [] [] [] [] [] [] | - rpm | [] [] | - screem | | - scrollkeeper | [] | - sed | [] [] [] [] [] [] [] [] [] | - sh-utils | [] [] [] [] [] [] [] | - shared-mime-info | [] [] [] | - sharutils | [] [] [] [] [] | - silky | () [] () () | - skencil | [] | - sketch | [] | - soundtracker | [] [] | - sp | [] () | - tar | [] [] [] [] [] [] [] [] [] | - texinfo | [] [] [] [] | - textutils | [] [] [] [] [] [] | - tin | [] () | - tp-robot | [] | - tuxpaint | [] [] [] [] [] [] [] [] [] | + 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 | [] [] [] | - xfree86_xkb_xml | [] [] | - xpad | [] [] | + unicode-transla... | | + util-linux | [] [] | + vorbis-tools | [] | + wastesedge | [] | + wdiff | [] [] | + wget | [] [] | + xchat | [] [] [] [] | + xkeyboard-config | [] | + xpad | [] [] [] | +-------------------------------------------------+ - et eu fa fi fr ga gl he hr hu id is it ja ko lg - 22 2 1 26 106 28 24 8 10 41 33 1 26 33 12 0 - - lt lv mk mn ms mt nb nl nn no nso pl pt pt_BR ro ru - +-----------------------------------------------------+ - a2ps | [] [] () () [] [] [] | - aegis | () () () | - ant-phone | [] [] | - anubis | [] [] [] [] [] [] | - ap-utils | [] () [] | - aspell | [] | - bash | [] [] [] | - batchelor | [] | - bfd | [] | - binutils | [] | - bison | [] [] [] [] [] | - bluez-pin | [] [] [] | - clisp | | - clisp | [] | - console-tools | [] | - coreutils | [] [] | - cpio | [] [] [] [] [] | - darkstat | [] [] [] [] | - diffutils | [] [] [] [] [] [] | - e2fsprogs | [] | - enscript | [] [] [] [] | - error | [] [] [] | - fetchmail | [] [] () [] | - fileutils | [] [] [] | - findutils | [] [] [] [] [] | - flex | [] [] [] [] | - fslint | [] [] | - gas | | - gawk | [] [] [] | - gbiff | [] [] | - gcal | | - gcc | | - gettext | [] [] [] | - gettext-examples | [] [] [] | - gettext-runtime | [] [] [] [] | - gettext-tools | [] [] | - gimp-print | [] | - gliv | [] [] [] | - glunarclock | [] [] [] [] | - gnubiff | [] | - gnucash | [] [] () [] | - gnucash-glossary | [] [] | - gnupg | [] | - gpe-aerial | [] [] [] [] | - gpe-beam | [] [] [] [] | - gpe-calendar | [] [] [] [] | - gpe-clock | [] [] [] [] | - gpe-conf | [] [] [] [] | - gpe-contacts | [] [] [] [] | - gpe-edit | [] [] [] [] | - gpe-go | [] [] [] | - gpe-login | [] [] [] [] | - gpe-ownerinfo | [] [] [] [] | - gpe-sketchbook | [] [] [] [] | - gpe-su | [] [] [] [] | - gpe-taskmanager | [] [] [] [] | - gpe-timesheet | [] [] [] [] | - gpe-today | [] [] [] [] | - gpe-todo | [] [] [] [] | - gphoto2 | [] | - gprof | [] [] | - gpsdrive | () () [] | - gramadoir | () [] | - grep | [] [] [] [] [] | - gretl | | - gtick | [] [] [] | - hello | [] [] [] [] [] [] [] [] [] [] | - id-utils | [] [] [] [] | - indent | [] [] [] [] | - iso_3166 | [] [] [] | - iso_3166_1 | [] [] | - iso_3166_2 | | - iso_3166_3 | [] | - iso_4217 | [] [] [] [] [] [] [] [] | - iso_639 | [] | - jpilot | () () | - jtag | | - jwhois | [] [] [] [] () | - kbd | [] [] [] | - latrine | [] | - ld | | - libc | [] [] [] [] | - libgpewidget | [] [] [] | - libiconv | [] [] [] [] [] | - lifelines | | - lilypond | | - lingoteach | | - lingoteach_lessons | | - lynx | [] [] [] | - m4 | [] [] [] [] [] | - mailutils | [] [] [] | - make | [] [] [] [] | - man-db | [] | - minicom | [] [] [] [] | - mysecretdiary | [] [] [] | - nano | [] [] [] [] [] | - nano_1_0 | [] [] [] [] [] [] | - opcodes | [] [] | - parted | [] [] [] [] | - ptx | [] [] [] [] [] [] [] [] | - python | | - radius | [] [] | - recode | [] [] [] [] | - rpm | [] [] [] | - screem | | - scrollkeeper | [] [] [] [] [] | - sed | [] [] [] | - sh-utils | [] [] | - shared-mime-info | [] [] | - sharutils | [] [] | - silky | () | - skencil | [] [] | - sketch | [] [] | - soundtracker | | - sp | | - tar | [] [] [] [] [] [] | - texinfo | [] [] [] [] | - textutils | [] [] | - tin | | - tp-robot | [] | - tuxpaint | [] [] [] [] [] [] [] [] | - unicode-han-tra... | | - unicode-transla... | | - util-linux | [] [] [] | - vorbis-tools | [] [] [] | - wastesedge | | - wdiff | [] [] [] [] [] | - wget | [] [] [] | - xchat | [] [] [] | - xfree86_xkb_xml | [] [] | - xpad | [] [] | - +-----------------------------------------------------+ - lt lv mk mn ms mt nb nl nn no nso pl pt pt_BR ro ru - 1 2 0 3 12 0 10 69 6 7 1 40 26 36 76 63 - - sk sl sr sv ta th tr uk ven vi wa xh zh_CN zh_TW zu - +-----------------------------------------------------+ - a2ps | [] [] [] [] | 16 - aegis | | 0 - ant-phone | | 3 - anubis | [] [] | 9 - ap-utils | () | 3 - aspell | | 4 - bash | | 9 - batchelor | | 3 - bfd | [] [] | 6 - binutils | [] [] [] | 8 - bison | [] [] | 14 - bluez-pin | [] [] [] | 14 - clisp | | 0 - clisp | | 5 - console-tools | | 3 - coreutils | [] [] [] [] | 16 - cpio | [] [] | 14 - darkstat | [] [] [] () () | 12 - diffutils | [] [] [] | 23 - e2fsprogs | [] [] | 6 - enscript | [] [] | 12 - error | [] [] [] | 15 - fetchmail | [] [] | 11 - fileutils | [] [] [] [] [] | 17 - findutils | [] [] [] [] [] [] | 29 - flex | [] [] | 13 - fslint | | 3 - gas | [] | 3 - gawk | [] [] | 12 - gbiff | | 4 - gcal | [] [] | 4 - gcc | [] | 4 - gettext | [] [] [] [] [] | 16 - gettext-examples | [] [] [] [] [] | 14 - gettext-runtime | [] [] [] [] [] [] [] [] | 22 - gettext-tools | [] [] [] [] [] [] | 14 - gimp-print | [] [] | 10 - gliv | | 3 - glunarclock | [] [] [] | 13 - gnubiff | | 3 - gnucash | [] [] | 9 - gnucash-glossary | [] [] [] | 8 - gnupg | [] [] [] [] | 17 - gpe-aerial | [] | 7 - gpe-beam | [] | 8 - gpe-calendar | [] [] [] [] | 13 - gpe-clock | [] [] [] | 10 - gpe-conf | [] [] | 9 - gpe-contacts | [] [] [] | 11 - gpe-edit | [] [] [] [] [] | 12 - gpe-go | | 5 - gpe-login | [] [] [] [] [] | 13 - gpe-ownerinfo | [] [] [] [] | 13 - gpe-sketchbook | [] [] | 9 - gpe-su | [] [] [] | 10 - gpe-taskmanager | [] [] [] | 10 - gpe-timesheet | [] [] [] [] | 12 - gpe-today | [] [] [] [] [] | 13 - gpe-todo | [] [] [] [] | 12 - gphoto2 | [] [] [] | 11 - gprof | [] [] | 9 - gpsdrive | [] [] | 3 - gramadoir | [] | 5 - grep | [] [] [] [] | 26 - gretl | | 3 - gtick | | 7 - hello | [] [] [] [] [] | 34 - id-utils | [] [] | 12 - indent | [] [] [] [] | 21 - iso_3166 | [] [] [] [] [] [] [] | 27 - iso_3166_1 | [] [] [] | 16 - iso_3166_2 | | 0 - iso_3166_3 | | 2 - iso_4217 | [] [] [] [] [] [] | 24 - iso_639 | | 1 - jpilot | [] [] [] [] [] | 9 - jtag | [] | 2 - jwhois | () [] [] | 11 - kbd | [] [] | 11 - latrine | | 2 - ld | [] [] | 5 - libc | [] [] [] [] | 20 - libgpewidget | [] [] [] [] | 13 - libiconv | [] [] [] [] [] [] [] [] | 27 - lifelines | [] | 2 - lilypond | [] | 3 - lingoteach | | 2 - lingoteach_lessons | () | 0 - lynx | [] [] [] | 14 - m4 | [] [] | 15 - mailutils | | 5 - make | [] [] [] | 16 - man-db | [] | 5 - minicom | | 11 - mysecretdiary | [] [] | 10 - nano | [] [] [] [] | 17 - nano_1_0 | [] [] [] | 17 - opcodes | [] [] | 6 - parted | [] [] [] | 15 - ptx | [] [] | 22 - python | | 0 - radius | | 4 - recode | [] [] [] | 20 - rpm | [] [] | 9 - screem | [] [] | 2 - scrollkeeper | [] [] [] | 15 - sed | [] [] [] [] [] [] | 24 - sh-utils | [] [] | 14 - shared-mime-info | [] [] | 7 - sharutils | [] [] [] [] | 17 - silky | () | 3 - skencil | [] | 6 - sketch | [] | 6 - soundtracker | [] [] | 7 - sp | [] | 3 - tar | [] [] [] [] [] | 24 - texinfo | [] [] [] | 14 - textutils | [] [] [] [] | 16 - tin | | 1 - tp-robot | | 2 - tuxpaint | [] [] [] [] [] | 29 - unicode-han-tra... | | 0 - unicode-transla... | | 2 - util-linux | [] [] | 15 - vorbis-tools | | 8 - wastesedge | | 0 - wdiff | [] [] [] | 18 - wget | [] [] [] [] [] [] [] [] | 24 - xchat | [] [] [] [] [] | 15 - xfree86_xkb_xml | [] [] [] [] [] | 11 - xpad | | 5 - +-----------------------------------------------------+ - 63 teams sk sl sr sv ta th tr uk ven vi wa xh zh_CN zh_TW zu - 131 domains 47 19 28 83 0 0 59 13 1 1 11 0 22 22 0 1373 + 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 @@ -742,13 +1075,13 @@ 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 January 2004 seems to be old, you may fetch a more recent copy of + 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'. -Using `gettext' in new packages -=============================== +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 @@ -1,3 +1,77 @@ +2007-02-18 Neil Jerram <neil@ossau.uklinux.net> + + * acinclude.m4 (AM_INTL_SUBDIR): Remove unnecessary dnl. + + * configure.in: Remove AM_GNU_GETTEXT_VERSION again. + + * Makefile.am (EXTRA_DIST): Add config.rpath. + + * config.rpath (Module): New (from gettext package). + +2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr> + + * configure.in: Look for `langinfo.h', `nl_types.h', `xlocale.h' + and `nl_langinfo'. + +2007-01-28 Neil Jerram <neil@ossau.uklinux.net> + + * configure.in: Do AM_GNU_GETTEXT_VERSION, so that autoreconf will + run autopoint. + + * acinclude.m4 (AM_INTL_SUBDIR): Provide dummy definition, to work + around current autoconf/automake/gettext bug. + + * INSTALL: New upstream version. + + * ABOUT-NLS: New upstream version. + +2007-01-22 Han-Wen Nienhuys <hanwen@lilypond.org> + + * .gitignore: new file. Make using git easier. + +2007-01-03 Han-Wen Nienhuys <hanwen@lilypond.org> + + * autogen.sh (Module): only try to run render-bugs if it exists. + +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-18 Ludovic Courtès <ludovic.courtes@laas.fr> * GUILE-VERSION: Added `LIBGUILE_I18N_*'. @@ -1,8 +1,8 @@ Installation Instructions ************************* -Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005 Free -Software Foundation, Inc. +Copyright (C) 1994, 1995, 1996, 1999, 2000, 2001, 2002, 2004, 2005, +2006 Free Software Foundation, Inc. This file is free documentation; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. @@ -10,7 +10,10 @@ unlimited permission to copy, distribute and modify it. Basic Installation ================== -These are generic installation instructions. +Briefly, the shell commands `./configure; make; make install' should +configure, build, and install this package. The following +more-detailed instructions are generic; see the `README' file for +instructions specific to this package. The `configure' shell script attempts to guess correct values for various system-dependent variables used during compilation. It uses @@ -23,9 +26,9 @@ debugging `configure'). It can also use an optional file (typically called `config.cache' and enabled with `--cache-file=config.cache' or simply `-C') that saves -the results of its tests to speed up reconfiguring. (Caching is +the results of its tests to speed up reconfiguring. Caching is disabled by default to prevent problems with accidental use of stale -cache files.) +cache files. If you need to do unusual things to compile the package, please try to figure out how `configure' could check whether to do them, and mail @@ -35,20 +38,17 @@ some point `config.cache' contains results you don't want to keep, you may remove or edit it. The file `configure.ac' (or `configure.in') is used to create -`configure' by a program called `autoconf'. You only need -`configure.ac' if you want to change it or regenerate `configure' using -a newer version of `autoconf'. +`configure' by a program called `autoconf'. You need `configure.ac' if +you want to change it or regenerate `configure' using a newer version +of `autoconf'. The simplest way to compile this package is: 1. `cd' to the directory containing the package's source code and type - `./configure' to configure the package for your system. If you're - using `csh' on an old version of System V, you might need to type - `sh ./configure' instead to prevent `csh' from trying to execute - `configure' itself. + `./configure' to configure the package for your system. - Running `configure' takes awhile. While running, it prints some - messages telling which features it is checking for. + Running `configure' might take a while. While running, it prints + some messages telling which features it is checking for. 2. Type `make' to compile the package. @@ -78,7 +78,7 @@ details on some of the pertinent environment variables. by setting variables in the command line or in the environment. Here is an example: - ./configure CC=c89 CFLAGS=-O2 LIBS=-lposix + ./configure CC=c99 CFLAGS=-g LIBS=-lposix *Note Defining Variables::, for more details. @@ -87,17 +87,15 @@ Compiling For Multiple Architectures You can compile the package for more than one kind of computer at the same time, by placing the object files for each architecture in their -own directory. To do this, you must use a version of `make' that -supports the `VPATH' variable, such as GNU `make'. `cd' to the +own directory. To do this, you can use GNU `make'. `cd' to the directory where you want the object files and executables to go and run the `configure' script. `configure' automatically checks for the source code in the directory that `configure' is in and in `..'. - If you have to use a `make' that does not support the `VPATH' -variable, you have to compile the package for one architecture at a -time in the source code directory. After you have installed the -package for one architecture, use `make distclean' before reconfiguring -for another architecture. + With a non-GNU `make', it is safer to compile the package for one +architecture at a time in the source code directory. After you have +installed the package for one architecture, use `make distclean' before +reconfiguring for another architecture. Installation Names ================== @@ -190,12 +188,12 @@ them in the `configure' command line, using `VAR=value'. For example: ./configure CC=/usr/local2/bin/gcc causes the specified `gcc' to be used as the C compiler (unless it is -overridden in the site shell script). Here is a another example: +overridden in the site shell script). - /bin/bash ./configure CONFIG_SHELL=/bin/bash +Unfortunately, this technique does not work for `CONFIG_SHELL' due to +an Autoconf bug. Until the bug is fixed you can use this workaround: -Here the `CONFIG_SHELL=/bin/bash' operand causes subsequent -configuration-related scripts to be executed by `/bin/bash'. + CONFIG_SHELL=/bin/bash /bin/bash ./configure CONFIG_SHELL=/bin/bash `configure' Invocation ====================== diff --git a/Makefile.am b/Makefile.am index ab72bed9f..7ead71f4b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -19,7 +19,10 @@ ## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth ## Floor, Boston, MA 02110-1301 USA -AUTOMAKE_OPTIONS = 1.5 +# 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 @@ -30,7 +33,7 @@ include_HEADERS = libguile.h # automake sometimes forgets to distribute acconfig.h, # apparently depending on the phase of the moon. -EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS +EXTRA_DIST = LICENSE HACKING GUILE-VERSION ANON-CVS SNAPSHOTS BUGS config.rpath TESTS = check-guile @@ -19,7 +19,40 @@ Changes in 1.9.XXXXXXXX: * Changes to the distribution * Changes to the stand-alone interpreter * Changes to Scheme functions and syntax -* Changes to the C interface + +** A new 'memoize-symbol evaluator trap has been added. This trap can +be used for efficiently implementing a Scheme code coverage. + +* Changes to the C interface + +** Functions for handling scm_option now no longer require an argument +indicating length of the scm_t_option array. + + +Changes in 1.8.2 (since 1.8.1): + +* New procedures (see the manual for details) + +** set-program-arguments + +* 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)". +** Build problems on Solaris fixed +** Build problems on Mingw fixed Changes in 1.8.1 (since 1.8.0): diff --git a/acinclude.m4 b/acinclude.m4 index 345e323b3..356c8218a 100644 --- a/acinclude.m4 +++ b/acinclude.m4 @@ -308,3 +308,5 @@ else fi AC_LANG_RESTORE ])dnl ACX_PTHREAD + +AC_DEFUN([AM_INTL_SUBDIR], []) diff --git a/autogen.sh b/autogen.sh index 90dc4805f..18e639b8c 100755 --- a/autogen.sh +++ b/autogen.sh @@ -31,8 +31,10 @@ ln -s $workbook/build/dist-files/.gdbinit examples/example.gdbinit # TODO: This should be moved to dist-guile mscripts=../guile-scripts -rm -f BUGS -$mscripts/render-bugs > BUGS +if test -x $mscripts/render-bugs ; then + rm -f BUGS + $mscripts/render-bugs > BUGS +fi ###################################################################### ### update infrastructure diff --git a/config.rpath b/config.rpath new file mode 100755 index 000000000..c492a93b6 --- /dev/null +++ b/config.rpath @@ -0,0 +1,614 @@ +#! /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-2006 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* | pw32* | os2*) + ;; + hpux9* | hpux10* | hpux11*) + wl='-Wl,' + ;; + irix5* | irix6* | nonstopux*) + wl='-Wl,' + ;; + newsos6) + ;; + linux*) + 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,' + ;; + sco3.2v5*) + ;; + solaris*) + wl='-Wl,' + ;; + sunos4*) + wl='-Qoption ld ' + ;; + sysv4 | sysv4.2uw2* | sysv4.3* | sysv5*) + wl='-Wl,' + ;; + sysv4*MP*) + ;; + 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 + aix3* | aix4* | aix5*) + # 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 + ;; + interix3*) + hardcode_direct=no + hardcode_libdir_flag_spec='${wl}-rpath,$libdir' + ;; + linux*) + 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 + ;; + aix4* | aix5*) + 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].*|aix5*) + 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 + hardcode_direct=yes + 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* | kfreebsd*-gnu | 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*) + 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 + ;; + 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*) + ;; + 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. +libname_spec='lib$name' +case "$host_os" in + aix3*) + ;; + aix4* | aix5*) + ;; + amigaos*) + ;; + beos*) + ;; + bsdi[45]*) + ;; + cygwin* | mingw* | pw32*) + shrext=.dll + ;; + darwin* | rhapsody*) + shrext=.dylib + ;; + dgux*) + ;; + freebsd1*) + ;; + kfreebsd*-gnu) + ;; + freebsd* | dragonfly*) + ;; + gnu*) + ;; + hpux9* | hpux10* | hpux11*) + case $host_cpu in + ia64*) + shrext=.so + ;; + hppa*64*) + shrext=.sl + ;; + *) + shrext=.sl + ;; + esac + ;; + interix3*) + ;; + irix5* | irix6* | nonstopux*) + 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*) + ;; + knetbsd*-gnu) + ;; + netbsd*) + ;; + newsos6) + ;; + nto-qnx*) + ;; + openbsd*) + ;; + os2*) + libname_spec='$name' + shrext=.dll + ;; + osf3* | osf4* | osf5*) + ;; + solaris*) + ;; + sunos4*) + ;; + sysv4 | sysv4.3*) + ;; + sysv4*MP*) + ;; + sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) + ;; + uts4*) + ;; +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_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" + +# 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 diff --git a/configure.in b/configure.in index c51ee3dbc..1be4a9f3f 100644 --- a/configure.in +++ b/configure.in @@ -29,7 +29,7 @@ AC_PREREQ(2.53) AC_INIT(m4_esyscmd(. ./GUILE-VERSION && echo -n ${PACKAGE}), m4_esyscmd(. ./GUILE-VERSION && echo -n ${GUILE_VERSION}), - [bug-guile@gnu.org]) + [bug-guile@gnu.org]) AC_CONFIG_AUX_DIR([.]) AC_CONFIG_SRCDIR(GUILE-VERSION) AM_INIT_AUTOMAKE([no-define]) @@ -55,7 +55,6 @@ AC_CONFIG_SUBDIRS(guile-readline) dnl Some more checks for Win32 AC_CYGWIN -AC_MINGW32 AC_LIBTOOL_WIN32_DLL AC_PROG_INSTALL @@ -68,6 +67,8 @@ AC_ISC_POSIX AC_MINIX AM_PROG_CC_STDC +# for per-target cflags in the libguile subdir +AM_PROG_CC_C_O AC_LIBTOOL_DLOPEN AC_PROG_LIBTOOL @@ -528,12 +529,14 @@ AC_HEADER_SYS_WAIT # Reasons for testing: # complex.h - new in C99 # fenv.h - available in C99, but not older systems +# process.h - mingw specific +# langinfo.h, nl_types.h - SuS v2 # -AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.h string.h \ +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]) +direct.h langinfo.h nl_types.h]) # "complex double" is new in C99, and "complex" is only a keyword if # <complex.h> is included @@ -560,9 +563,11 @@ AC_TYPE_GETGROUPS AC_TYPE_SIGNAL AC_TYPE_MODE_T -if test $MINGW32 = no; then - AC_CHECK_LIB(m, main) -fi +# 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) @@ -577,7 +582,8 @@ dnl dnl Check for Winsock and other functionality on Win32 (*not* CygWin) dnl EXTRA_DEFS="" -if test "$MINGW32" = "yes" ; then +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) @@ -591,7 +597,8 @@ if test "$MINGW32" = "yes" ; then AC_DEFINE(USE_DLL_IMPORT, 1, [Define if you need additional CPP macros on Win32 platforms.]) fi -fi + ;; +esac AC_SUBST(EXTRA_DEFS) # Reasons for testing: @@ -610,23 +617,29 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # 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 # 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 -# strcoll_l, newlocale - GNU extensions (glibc) +# strcoll_l, newlocale - GNU extensions (glibc), also available on Darwin +# nl_langinfo - X/Open, not available on Windows. # -AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice readdir_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 strcoll strcoll_l newlocale]) +AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe readdir_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 strcoll strcoll_l newlocale nl_langinfo]) # 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 +# xlocale.h - needed on Darwin for the `locale_t' API # -AC_CHECK_HEADERS(crypt.h netdb.h sys/param.h sys/resource.h sys/file.h) +AC_CHECK_HEADERS(crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h xlocale.h) AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname) AC_CHECK_DECLS([sethostname]) @@ -794,7 +807,7 @@ AC_CACHE_VAL(guile_cv_have_uint32_t, #if HAVE_STDINT_H #include <stdint.h> #endif - #ifndef __MINGW32__ + #ifndef HAVE_NETDB_H #include <netdb.h> #endif], [uint32_t a;], @@ -1047,17 +1060,22 @@ if test $scm_cv_struct_linger = yes; then fi +# On mingw, struct timespec is in <pthread.h>. +# AC_MSG_CHECKING(for struct timespec) AC_CACHE_VAL(scm_cv_struct_timespec, AC_TRY_COMPILE([ -#include <time.h>], +#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 <time.h>.]) + [Define this if your system defines struct timespec via either <time.h> or <pthread.h>.]) fi #-------------------------------------------------------------------- @@ -1091,8 +1109,11 @@ case "$with_threads" in # 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) + 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 };". diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 8b8e0befe..c09bc96d0 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,55 @@ +2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr> + + * api-data.texi (Conversion): Made cross refs point to `Number + Input and Output' rather than `The ice-9 i18n Module'. + (String Comparison): Likewise for `Text Collation'. + * api-i18n.texi (Internationalization): Re-organized the whole + section, documented new i18n features. Added the following + subsections: `i18n Introduction', `Text Collation', `Character + Case Mapping', `Number Input and Output', `Accessing Locale + Information'. Removed `The ice-9 i18n Module'. + * posix.texi (Locales): Updated cross-ref formerly pointing to + `The ice-9 i18n Module'. + * srfi-modules.texi (SRFI-19 String to date): Mention the + internationalization of `string->date'. + +2007-01-19 Han-Wen Nienhuys <hanwen@lilypond.org> + + * api-options.texi (Evaluator trap options): document + memoize-symbol-handler + + * api-evaluation.texi (Evaluator Behaviour): link to the Evaluator + trap options node in trap-enable/trap-set! doco. + +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-11-18 Ludovic Courtès <ludovic.courtes@laas.fr> * Makefile.am (BUILT_SOURCES): New variable. diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 11a276a13..512733cd5 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1476,7 +1476,7 @@ 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} above. +Throw an error, as per @code{scm-error} (@pxref{Error Reporting}). @end deftypefn @deftypefn {C Function} void scm_syserror (char *@var{subr}) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index abcb28de1..df913b2cd 100755 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 +@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. @@ -1015,7 +1015,7 @@ zero. The following procedures read and write numbers according to their external representation as defined by R5RS (@pxref{Lexical structure, R5RS Lexical Structure,, r5rs, The Revised^5 Report on the Algorithmic -Language Scheme}). @xref{The ice-9 i18n Module, the @code{(ice-9 +Language Scheme}). @xref{Number Input and Output, the @code{(ice-9 i18n)} module}, for locale-dependent number parsing. @deffn {Scheme Procedure} number->string n [radix] @@ -2949,7 +2949,7 @@ 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. @xref{The ice-9 i18n Module, the @code{(ice-9 +when comparing strings. @xref{Text Collation, the @code{(ice-9 i18n)} module}, for locale-dependent string comparison. @rnindex string=? @@ -3525,7 +3525,7 @@ 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. -It defaults to @code{(lambda (x) )}. +The default is nothing extra. @end itemize @end deffn diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index 5f816dc46..68c202266 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -615,14 +615,21 @@ Invoke the Guile debugger to explore the context of the last error. @cindex Low level trap calls @cindex Evaluator trap calls -Guile's evaluator can be configured to call three user-specified -procedures at various points in its operation: an -@dfn{apply-frame-handler} procedure, an @dfn{enter-frame-handler} -procedure, and an @dfn{exit-frame-handler} procedure. 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}). +Guile's evaluator can be configured to call the following four user-specified +procedures at various points in its operation. + +@table @dfn +@item apply-frame-handler +@item enter-frame-handler +@item exit-frame-handler +@item memoize-symbol-handler +@end table + +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}). It is not necessary to understand the fine details of these low level calls, and of the options which configure them, in order to use the diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 1da13de43..6fd363df2 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -629,6 +629,9 @@ Like @code{help}, but also print programmer options. 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] diff --git a/doc/ref/api-i18n.texi b/doc/ref/api-i18n.texi index 1927a755b..be5afe4f9 100644 --- a/doc/ref/api-i18n.texi +++ b/doc/ref/api-i18n.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 +@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. @@ -11,24 +11,29 @@ @cindex internationalization @cindex i18n -Guile provides internationalization support for Scheme programs in two -ways. First, procedures to manipulate text and data in a way that -conforms to particular cultural conventions (i.e., in a -``locale-dependent'' way) are provided in the @code{(ice-9 i18n)}. -Second, Guile allows the use of GNU @code{gettext} to translate -program message strings. +Guile provides internationalization@footnote{For concision and style, +programmers often like to refer to internationalization as ``i18n''.} +support for Scheme programs in two ways. First, procedures to +manipulate text and data in a way that conforms to particular cultural +conventions (i.e., in a ``locale-dependent'' way) are provided in the +@code{(ice-9 i18n)}. Second, Guile allows the use of GNU +@code{gettext} to translate program message strings. @menu -* The ice-9 i18n Module:: Honoring cultural conventions. -* Gettext Support:: Translating message strings. +* i18n Introduction:: Introduction to Guile's i18n support. +* Text Collation:: Sorting strings and characters. +* Character Case Mapping:: Case mapping. +* Number Input and Output:: Parsing and printing numbers. +* Accessing Locale Information:: Detailed locale information. +* Gettext Support:: Translating message strings. @end menu -@node The ice-9 i18n Module -@subsection The @code{(ice-9 i18n)} Module +@node i18n Introduction, Text Collation, Internationalization, Internationalization +@subsection Internationalization with Guile -In order to make use of the following functions, one must import the -@code{(ice-9 i18n)} module in the usual way: +In order to make use of the functions described thereafter, the +@code{(ice-9 i18n)} module must be imported in the usual way: @example (use-modules (ice-9 i18n)) @@ -64,83 +69,41 @@ the user is defined by the @code{LC_MESSAGES} category The procedures provided by this module allow the development of programs that adapt automatically to any locale setting. As we will -see later, many of the locale-dependent procedures provided by this -module can optionally take a @dfn{locale object} argument. This -additional argument defines the locale settings that must be followed -by the invoked procedure. When it is omitted, then the current locale -settings of the process are followed (@pxref{Locales, -@code{setlocale}}). +see later, many of these procedures can optionally take a @dfn{locale +object} argument. This additional argument defines the locale +settings that must be followed by the invoked procedure. When it is +omitted, then the current locale settings of the process are followed +(@pxref{Locales, @code{setlocale}}). The following procedures allow the manipulation of such locale objects. -@deffn {Scheme Procedure} make-locale category-mask locale-name [base-locale] -@deffnx {C Function} scm_make_locale (category_mask, locale_name, base_locale) +@deffn {Scheme Procedure} make-locale category-list locale-name [base-locale] +@deffnx {C Function} scm_make_locale (category_list, locale_name, base_locale) Return a reference to a data structure representing a set of locale datasets. @var{locale-name} should be a string denoting a particular -locale, e.g., @code{"aa_DJ"}. Unlike for the @var{category} parameter -for @code{setlocale}, the @var{category-mask} parameter here uses a -single bit for each category, made by OR'ing together @code{LC_*_MASK} -bits. The optional @var{base-locale} argument can be used to specify -a locale object whose settings are to be used as a basis for the -locale object being returned. - -The available locale category masks are the following: - -@defvar LC_COLLATE_MASK -Represents the collation locale category. -@end defvar -@defvar LC_CTYPE_MASK -Represents the character classification locale category. -@end defvar -@defvar LC_MESSAGES_MASK -Represents the messages locale category. -@end defvar -@defvar LC_MONETARY_MASK -Represents the monetary locale category. -@end defvar -@defvar LC_NUMERIC_MASK -Represents the way numbers are displayed. -@end defvar -@defvar LC_TIME_MASK -Represents the way date and time are displayed -@end defvar - -The following category masks are also available but will not have any -effect on systems that do not support them: - -@defvar LC_PAPER_MASK -@defvarx LC_NAME_MASK -@defvarx LC_ADDRESS_MASK -@defvarx LC_TELEPHONE_MASK -@defvarx LC_MEASUREMENT_MASK -@defvarx LC_IDENTIFICATION_MASK -@end defvar - -Finally, there is also: - -@defvar LC_ALL_MASK -This represents all the locale categories supported by the system. -@end defvar - -The @code{LC_*_MASK} variables are bound to integers which may be OR'd -together using @code{logior} (@pxref{Primitive Numerics, -@code{logior}}). For instance, the following invocation creates a -locale object that combines the use of Esperanto for messages and -character classification with the default settings for the other -categories (i.e., the settings of the default @code{C} locale which -usually represents conventions in use in the USA): +locale (e.g., @code{"aa_DJ"}) and @var{category-list} should be either +a list of locale categories or a single category as used with +@code{setlocale} (@pxref{Locales, @code{setlocale}}). Optionally, if +@code{base-locale} is passed, it should be a locale object denoting +settings for categories not listed in @var{category-list}. + +The following invocation creates a locale object that combines the use +of Swedish for messages and character classification with the +default settings for the other categories (i.e., the settings of the +default @code{C} locale which usually represents conventions in use in +the USA): @example -(make-locale (logior LC_MESSAGE_MASK LC_CTYPE_MASK) "eo_EO") +(make-locale (list LC_MESSAGE LC_CTYPE) "sv_SE") @end example -The following example combines the use of Swedish conventions with -monetary conventions from Croatia: +The following example combines the use of Esperanto messages and +conventions with monetary conventions from Croatia: @example -(make-locale LC_MONETARY_MASK "hr_HR" - (make-locale LC_ALL_MASK "sv_SE")) +(make-locale LC_MONETARY "hr_HR" + (make-locale LC_ALL "eo_EO")) @end example A @code{system-error} exception (@pxref{Handling Errors}) is raised by @@ -155,70 +118,56 @@ error may be raised later, when the locale object is actually used. Return true if @var{obj} is a locale object. @end deffn -The following procedures provide support for text collation. +@defvr {Scheme Variable} %global-locale +@defvrx {C Variable} scm_global_locale +This variable is bound to a locale object denoting the current process +locale as installed using @code{setlocale ()} (@pxref{Locales}). It +may be used like any other locale object, including as a third +argument to @code{make-locale}, for instance. +@end defvr + + +@node Text Collation, Character Case Mapping, i18n Introduction, Internationalization +@subsection Text Collation + +The following procedures provide support for text collation, i.e., +locale-dependent string and character sorting. @deffn {Scheme Procedure} string-locale<? s1 s2 [locale] @deffnx {C Function} scm_string_locale_lt (s1, s2, locale) -Compare strings @var{s1} and @var{s2} in a locale-dependent way. If -@var{locale} is provided, it should be locale object (as returned by -@code{make-locale}) and will be used to perform the comparison; -otherwise, the current system locale is used. -@end deffn - -@deffn {Scheme Procedure} string-locale>? s1 s2 [locale] +@deffnx {Scheme Procedure} string-locale>? s1 s2 [locale] @deffnx {C Function} scm_string_locale_gt (s1, s2, locale) +@deffnx {Scheme Procedure} string-locale-ci<? s1 s2 [locale] +@deffnx {C Function} scm_string_locale_ci_lt (s1, s2, locale) +@deffnx {Scheme Procedure} string-locale-ci>? s1 s2 [locale] +@deffnx {C Function} scm_string_locale_ci_gt (s1, s2, locale) Compare strings @var{s1} and @var{s2} in a locale-dependent way. If @var{locale} is provided, it should be locale object (as returned by @code{make-locale}) and will be used to perform the comparison; -otherwise, the current system locale is used. -@end deffn - -@deffn {Scheme Procedure} string-locale-ci<? s1 s2 [locale] -@deffnx {C Function} scm_string_locale_ci_lt (s1, s2, locale) -Compare strings @var{s1} and @var{s2} in a case-insensitive, and -locale-dependent way. If @var{locale} is provided, it should be -locale object (as returned by @code{make-locale}) and will be used to -perform the comparison; otherwise, the current system locale is used. -@end deffn - -@deffn {Scheme Procedure} string-locale-ci>? s1 s2 [locale] -@deffnx {C Function} scm_string_locale_ci_gt (s1, s2, locale) -Compare strings @var{s1} and @var{s2} in a case-insensitive, and -locale-dependent way. If @var{locale} is provided, it should be -locale object (as returned by @code{make-locale}) and will be used to -perform the comparison; otherwise, the current system locale is used. +otherwise, the current system locale is used. For the @code{-ci} +variants, the comparison is made in a case-insensitive way. @end deffn @deffn {Scheme Procedure} string-locale-ci=? s1 s2 [locale] @deffnx {C Function} scm_string_locale_ci_eq (s1, s2, locale) Compare strings @var{s1} and @var{s2} in a case-insensitive, and locale-dependent way. If @var{locale} is provided, it should be -locale object (as returned by @code{make-locale}) and will be used to +a locale object (as returned by @code{make-locale}) and will be used to perform the comparison; otherwise, the current system locale is used. @end deffn @deffn {Scheme Procedure} char-locale<? c1 c2 [locale] @deffnx {C Function} scm_char_locale_lt (c1, c2, locale) -Return true if character @var{c1} is lower than @var{c2} according to -@var{locale} or to the current locale. -@end deffn - -@deffn {Scheme Procedure} char-locale>? c1 c2 [locale] +@deffnx {Scheme Procedure} char-locale>? c1 c2 [locale] @deffnx {C Function} scm_char_locale_gt (c1, c2, locale) -Return true if character @var{c1} is greater than @var{c2} according -to @var{locale} or to the current locale. -@end deffn - -@deffn {Scheme Procedure} char-locale-ci<? c1 c2 [locale] +@deffnx {Scheme Procedure} char-locale-ci<? c1 c2 [locale] @deffnx {C Function} scm_char_locale_ci_lt (c1, c2, locale) -Return true if character @var{c1} is lower than @var{c2}, in a case -insensitive way according to @var{locale} or to the current locale. -@end deffn - -@deffn {Scheme Procedure} char-locale-ci>? c1 c2 [locale] +@deffnx {Scheme Procedure} char-locale-ci>? c1 c2 [locale] @deffnx {C Function} scm_char_locale_ci_gt (c1, c2, locale) -Return true if character @var{c1} is greater than @var{c2}, in a case -insensitive way according to @var{locale} or to the current locale. +Compare characters @var{c1} and @var{c2} according to either +@var{locale} (a locale object as returned by @code{make-locale}) or +the current locale. For the @code{-ci} variants, the comparison is +made in a case-insensitive way. @end deffn @deffn {Scheme Procedure} char-locale-ci=? c1 c2 [locale] @@ -227,6 +176,9 @@ Return true if character @var{c1} is equal to @var{c2}, in a case insensitive way according to @var{locale} or to the current locale. @end deffn +@node Character Case Mapping, Number Input and Output, Text Collation, Internationalization +@subsection Character Case Mapping + The procedures below provide support for ``character case mapping'', i.e., to convert characters or strings to their upper-case or lower-case equivalent. Note that SRFI-13 provides procedures that @@ -236,8 +188,8 @@ account specificities of the customs in use in a particular language or region of the world. For instance, while most languages using the Latin alphabet map lower-case letter ``i'' to upper-case letter ``I'', Turkish maps lower-case ``i'' to ``Latin capital letter I with dot -above''. The following procedures allow to provide idiomatic -character mapping. +above''. The following procedures allow programmers to provide +idiomatic character mapping. @deffn {Scheme Procedure} char-locale-downcase chr [locale] @deffnx {C Function} scm_char_locale_upcase (chr, locale) @@ -263,12 +215,20 @@ Return a new string that is the down-case version of @var{str} according to either @var{locale} or the current locale. @end deffn -Finally, the following procedures allow programs to read numbers +Note that in the current implementation Guile has no notion of +multibyte characters and in a multibyte locale characters may not be +converted correctly. + +@node Number Input and Output, Accessing Locale Information, Character Case Mapping, Internationalization +@subsection Number Input and Output + +The following procedures allow programs to read and write numbers written according to a particular locale. As an example, in English, ``ten thousand and a half'' is usually written @code{10,000.5} while -in French it is written @code{10000,5}. These procedures allow to -account for these differences. +in French it is written @code{10 000,5}. These procedures allow such +differences to be taken into account. +@findex strtod @deffn {Scheme Procedure} locale-string->integer str [base [locale]] @deffnx {C Function} scm_locale_string_to_integer (str, base, locale) Convert string @var{str} into an integer according to either @@ -276,22 +236,239 @@ Convert string @var{str} into an integer according to either the current process locale. If @var{base} is specified, then it determines the base of the integer being read (e.g., @code{16} for an hexadecimal number, @code{10} for a decimal number); by default, -decimal numbers are read. Return two values: an integer (on success) -or @code{#f}, and the number of characters read from @var{str} -(@code{0} on failure). +decimal numbers are read. Return two values (@pxref{Multiple +Values}): an integer (on success) or @code{#f}, and the number of +characters read from @var{str} (@code{0} on failure). + +This function is based on the C library's @code{strtol} function +(@pxref{Parsing of Integers, @code{strtol},, libc, The GNU C Library +Reference Manual}). @end deffn +@findex strtod @deffn {Scheme Procedure} locale-string->inexact str [locale] @deffnx {C Function} scm_locale_string_to_inexact (str, locale) Convert string @var{str} into an inexact number according to either @var{locale} (a locale object as returned by @code{make-locale}) or -the current process locale. Return two values: an inexact number (on -success) or @code{#f}, and the number of characters read from -@var{str} (@code{0} on failure). +the current process locale. Return two values (@pxref{Multiple +Values}): an inexact number (on success) or @code{#f}, and the number +of characters read from @var{str} (@code{0} on failure). + +This function is based on the C library's @code{strtod} function +(@pxref{Parsing of Floats, @code{strtod},, libc, The GNU C Library +Reference Manual}). +@end deffn + +@deffn {Scheme Procedure} number->locale-string number [fraction-digits [locale]] +Convert @var{number} (an inexact) into a string according to the +cultural conventions of either @var{locale} (a locale object) or the +current locale. Optionally, @var{fraction-digits} may be bound to an +integer specifying the number of fractional digits to be displayed. +@end deffn + +@deffn {Scheme Procedure} monetary-amount->locale-string amount intl? [locale] +Convert @var{amount} (an inexact denoting a monetary amount) into a +string according to the cultural conventions of either @var{locale} (a +locale object) or the current locale. If @var{intl?} is true, then +the international monetary format for the given locale is used +(@pxref{Currency Symbol, international and locale monetary formats,, +libc, The GNU C Library Reference Manual}). +@end deffn + + +@node Accessing Locale Information, Gettext Support, Number Input and Output, Internationalization +@subsection Accessing Locale Information + +@findex nl_langinfo +@cindex low-level locale information +It is sometimes useful to obtain very specific information about a +locale such as the word it uses for days or months, its format for +representing floating-point figures, etc. The @code{(ice-9 i18n)} +module provides support for this in a way that is similar to the libc +functions @code{nl_langinfo ()} and @code{localeconv ()} +(@pxref{Locale Information, accessing locale information from C,, +libc, The GNU C Library Reference Manual}). The available functions +are listed below. + +@deffn {Scheme Procedure} locale-encoding [locale] +Return the name of the encoding (a string whose interpretation is +system-dependent) of either @var{locale} or the current locale. +@end deffn + +The following functions deal with dates and times. + +@deffn {Scheme Procedure} locale-day day [locale] +@deffnx {Scheme Procedure} locale-day-short day [locale] +@deffnx {Scheme Procedure} locale-month month [locale] +@deffnx {Scheme Procedure} locale-month-short month [locale] +Return the word (a string) used in either @var{locale} or the current +locale to name the day (or month) denoted by @var{day} (or +@var{month}), an integer between 1 and 7 (or 1 and 12). The +@code{-short} variants provide an abbreviation instead of a full name. +@end deffn + +@deffn {Scheme Procedure} locale-am-string [locale] +@deffnx {Scheme Procedure} locale-pm-string [locale] +Return a (potentially empty) string that is used to denote @i{ante +meridiem} (or @i{post meridiem}) hours in 12-hour format. +@end deffn + +@deffn {Scheme Procedure} locale-date+time-format [locale] +@deffnx {Scheme Procedure} locale-date-format [locale] +@deffnx {Scheme Procedure} locale-time-format [locale] +@deffnx {Scheme Procedure} locale-time+am/pm-format [locale] +@deffnx {Scheme Procedure} locale-era-date-format [locale] +@deffnx {Scheme Procedure} locale-era-date+time-format [locale] +@deffnx {Scheme Procedure} locale-era-time-format [locale] +These procedures return format strings suitable to @code{strftime} +(@pxref{Time}) that may be used to display (part of) a date/time +according to certain constraints and to the conventions of either +@var{locale} or the current locale (@pxref{The Elegant and Fast Way, +the @code{nl_langinfo ()} items,, libc, The GNU C Library Reference +Manual}). +@end deffn + +@deffn {Scheme Procedure} locale-era [locale] +@deffnx {Scheme Procedure} locale-era-year [locale] +These functions return, respectively, the era and the year of the +relevant era used in @var{locale} or the current locale. Most locales +do not define this value. In this case, the empty string is returned. +An example of a locale that does define this value is the Japanese +one. @end deffn +The following procedures give information about number representation. + +@deffn {Scheme Procedure} locale-decimal-point [locale] +@deffnx {Scheme Procedure} locale-thousands-separator [locale] +These functions return a string denoting the representation of the +decimal point or that of the thousand separator (respectively) for +either @var{locale} or the current locale. +@end deffn + +@deffn {Scheme Procedure} locale-digit-grouping [locale] +Return a (potentially circular) list of integers denoting how digits +of the integer part of a number are to be grouped, starting at the +decimal point and going to the left. The list contains integers +indicating the size of the successive groups, from right to left. If +the list is non-circular, then no grouping occurs for digits beyond +the last group. + +For instance, if the returned list is a circular list that contains +only @code{3} and the thousand separator is @code{","} (as is the case +with English locales), then the number @code{12345678} should be +printed @code{12,345,678}. +@end deffn + +The following procedures deal with the representation of monetary +amounts. Some of them take an additional @var{intl?} argument (a +boolean) that tells whether the international or local monetary +conventions for the given locale are to be used. + +@deffn {Scheme Procedure} locale-monetary-decimal-point [locale] +@deffnx {Scheme Procedure} locale-monetary-thousands-separator [locale] +@deffnx {Scheme Procedure} locale-monetary-grouping [locale] +These are the monetary counterparts of the above procedures. These +procedures apply to monetary amounts. +@end deffn + +@deffn {Scheme Procedure} locale-currency-symbol intl? [locale] +Return the currency symbol (a string) of either @var{locale} or the +current locale. + +The following example illustrates the difference between the local and +international monetary formats: + +@example +(define us (make-locale LC_MONETARY "en_US")) +(locale-currency-symbol #f us) +@result{} "-$" +(locale-currency-symbol #t us) +@result{} "USD " +@end example +@end deffn + +@deffn {Scheme Procedure} locale-monetary-fractional-digits intl? [locale] +Return the number of fractional digits to be used when printing +monetary amounts according to either @var{locale} or the current +locale. If the locale does not specify it, then @code{#f} is +returned. +@end deffn + +@deffn {Scheme Procedure} locale-currency-symbol-precedes-positive? intl? [locale] +@deffnx {Scheme Procedure} locale-currency-symbol-precedes-negative? intl? [locale] +@deffnx {Scheme Procedure} locale-positive-separated-by-space? intl? [locale] +@deffnx {Scheme Procedure} locale-negative-separated-by-space? intl? [locale] +These procedures return a boolean indicating whether the currency +symbol should precede a positive/negative number, and whether a +whitespace should be inserted between the currency symbol and a +positive/negative amount. +@end deffn + +@deffn {Scheme Procedure} locale-monetary-positive-sign [locale] +@deffnx {Scheme Procedure} locale-monetary-negative-sign [locale] +Return a string denoting the positive (respectively negative) sign +that should be used when printing a monetary amount. +@end deffn + +@deffn {Scheme Procedure} locale-positive-sign-position +@deffnx {Scheme Procedure} locale-negative-sign-position +These functions return a symbol telling where a sign of a +positive/negative monetary amount is to appear when printing it. The +possible values are: + +@table @code +@item parenthesize +The currency symbol and quantity should be surrounded by parentheses. +@item sign-before +Print the sign string before the quantity and currency symbol. +@item sign-after +Print the sign string after the quantity and currency symbol. +@item sign-before-currency-symbol +Print the sign string right before the currency symbol. +@item sign-after-currency-symbol +Print the sign string right after the currency symbol. +@item unspecified +Unspecified. We recommend you print the sign after the currency +symbol. +@end table + +@end deffn + +Finally, the two following procedures may be helpful when programming +user interfaces: + +@deffn {Scheme Procedure} locale-yes-regexp [locale] +@deffnx {Scheme Procedure} locale-no-regexp [locale] +Return a string that can be used as a regular expression to recognize +a positive (respectively, negative) response to a yes/no question. +For the C locale, the default values are typically @code{"^[yY]"} and +@code{"^[nN]"}, respectively. + +Here is an example: + +@example +(format #t "Does Guile rock?~%") +(let ((answer (read-line))) + (cond ((string-match (locale-yes-regexp) answer) + "Yes it does.") + ((string-match (locale-no-regexp) answer) + "No it doesn't.") + (else + "What do you mean?"))) +@end example + +For an internationalized yes/no string output, @code{gettext} should +be used (@pxref{Gettext Support}). +@end deffn + +Example uses of some of these functions are the implementation of the +@code{number->locale-string} and @code{monetary-amount->locale-string} +procedures (@pxref{Number Input and Output}), as well as that the +SRFI-19 date and time convertion to/from strings (@pxref{SRFI-19}). + -@node Gettext Support +@node Gettext Support, , Accessing Locale Information, Internationalization @subsection Gettext Support Guile provides an interface to GNU @code{gettext} for translating diff --git a/doc/ref/api-init.texi b/doc/ref/api-init.texi index 26e6e71ef..0e4e8b8b7 100644 --- a/doc/ref/api-init.texi +++ b/doc/ref/api-init.texi @@ -1,12 +1,13 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@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 @@ -93,7 +94,8 @@ 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. +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}) diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi index 6dbc37062..493e2385d 100644 --- a/doc/ref/api-options.texi +++ b/doc/ref/api-options.texi @@ -554,6 +554,7 @@ Here is the list of evaluator trap options generated by typing 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. +memoize-symbol no Trap when eval memoizes a symbol's value traps yes Enable evaluator traps. @end smallexample @@ -612,6 +613,20 @@ way. @var{retval} is the return value. @end deffn + +@deffn memoize-symbol-handler key cont expression env +Called when the evaluator memoizes the value of a procedure symbol + +@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 + + @node Debugger options @subsubsection Debugger options diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index e6d520ddf..7fd0f4fa4 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -198,30 +198,72 @@ evaluated in order. @node let-keywords Reference @subsubsection let-keywords Reference -@c FIXME::martin: Review me! - -@code{let-keywords} and @code{let-keywords*} are used for extracting -values from argument lists which use keywords instead of argument -position for binding local variables to argument values. - -@code{let-keywords} binds all variables simultaneously, while -@code{let-keywords*} binds them sequentially, consistent with @code{let} -and @code{let*} (@pxref{Local Bindings}). - -@deffn {library syntax} let-keywords rest-arg allow-other-keys? (binding @dots{}) expr @dots{} -@deffnx {library syntax} let-keywords* rest-arg allow-other-keys? (binding @dots{}) expr @dots{} -These macros pick out keyword arguments from @var{rest-arg}, but do not -modify it. This is consistent at least with Common Lisp, which -duplicates keyword arguments in the rest argument. More explanation of what -keyword arguments in a lambda list look like can be found below in -the documentation for @code{lambda*} - (@pxref{lambda* Reference}). @var{binding}s can have the same form as -for @code{let-optional}. If @var{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. - -After binding the variables, the expressions @var{expr} @dots{} are -evaluated in order. +@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 diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 6f496fe8d..faf57d6b1 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 +@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. @@ -1348,15 +1348,72 @@ included but subprocesses are not. @deffn {Scheme Procedure} program-arguments @deffnx {Scheme Procedure} command-line +@deffnx {Scheme Procedure} set-program-arguments @deffnx {C Function} scm_program_arguments () +@deffnx {C Function} scm_set_program_arguments_scm (lst) @cindex command line @cindex program arguments -Return the list of command line arguments passed to Guile, as a list of -strings. The list includes the invoked program name, which is usually -@code{"guile"}, but excludes switches and parameters for command line -options like @code{-e} and @code{-l}. +Get the command line arguments passed to Guile, or set new arguments. + +The arguments are a list of strings, the first of which is the invoked +program name. This is just @nicode{"guile"} (or the executable path) +when run interactively, or it's the script name when running a script +with @option{-s} (@pxref{Invoking Guile}). + +@example +guile -L /my/extra/dir -s foo.scm abc def + +(program-arguments) @result{} ("foo.scm" "abc" "def") +@end example + +@code{set-program-arguments} allows a library module or similar to +modify the arguments, for example to strip options it recognises, +leaving the rest for the mainline. + +The argument list is held in a fluid, which means it's separate for +each thread. Neither the list nor the strings within it are copied at +any point and normally should not be mutated. + +The two names @code{program-arguments} and @code{command-line} are an +historical accident, they both do exactly the same thing. The name +@code{scm_set_program_arguments_scm} has an extra @code{_scm} on the +end to avoid clashing with the C function below. @end deffn +@deftypefn {C Function} void scm_set_program_arguments (int argc, char **argv, char *first) +@cindex command line +@cindex program arguments +Set the list of command line arguments for @code{program-arguments} +and @code{command-line} above. + +@var{argv} is an array of null-terminated strings, as in a C +@code{main} function. @var{argc} is the number of strings in +@var{argv}, or if it's negative then a @code{NULL} entry in @var{argv} +marks its end. + +@var{first} is an extra string put at the start of the arguments, or +@code{NULL} for no such extra. This is a convenient way to pass the +program name after advancing @var{argv} to strip option arguments. + +@example +@{ + char *progname = argv[0]; + int i; + for (argv++; argv[0] != NULL && argv[0][0] == '-'; argv++) + @{ + /* munch option ... */ + @} + /* remaining args for scheme level use */ + scm_set_program_arguments (-1, argv, progname); +@} +@end example + +This sort of thing is often done at startup under +@code{scm_boot_guile} with any options handled at the C level removed. +The given strings are all copied, so the C data is not accessed again +once @code{scm_set_program_arguments} returns. +@end deftypefn + @deffn {Scheme Procedure} getenv nam @deffnx {C Function} scm_getenv (nam) @cindex environment @@ -3162,7 +3219,7 @@ Locales and Internationalization, libc, The GNU C Library Reference Manual}. Note that @code{setlocale} affects locale settings for the whole -process. @xref{The ice-9 i18n Module, locale objects and +process. @xref{i18n Introduction, locale objects and @code{make-locale}}, for a thread-safe alternative. @end deffn @@ -3174,12 +3231,13 @@ Please note that the procedures in this section are not suited for strong encryption, they are only interfaces to the well-known and common system library functions of the same name. They are just as good (or bad) as the underlying functions, so you should refer to your system -documentation before using them. +documentation before using them (@pxref{crypt,, Encrypting Passwords, +libc, The GNU C Library Reference Manual}). @deffn {Scheme Procedure} crypt key salt @deffnx {C Function} scm_crypt (key, salt) -Encrypt @var{key} using @var{salt} as the salt value to the -crypt(3) library call. +Encrypt @var{key}, with the addition of @var{salt} (both strings), +using the @code{crypt} C library call. @end deffn Although @code{getpass} is not an encryption procedure per se, it diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 8a027c00b..df356cc58 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@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. @@ -1616,24 +1616,61 @@ applied to zero arguments, yields 1. @subsection SRFI-17 - Generalized set! @cindex SRFI-17 -This is an implementation of SRFI-17: Generalized set! +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 -@findex getter-with-setter -It exports the Guile procedure @code{make-procedure-with-setter} under -the SRFI name @code{getter-with-setter} and exports the standard -procedures @code{car}, @code{cdr}, @dots{}, @code{cdddr}, -@code{string-ref} and @code{vector-ref} as procedures with setters, as -required by the SRFI. +@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 -SRFI-17 was heavily criticized during its discussion period but it was -finalized anyway. One issue was its concept of globally associating -setter @dfn{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, @code{(set! (setter @var{proc}) -@var{setter})} signals an error. The only way to attach a setter to a -procedure is to create a new object (a @dfn{procedure with setter}) via -the @code{getter-with-setter} procedure. This procedure is also -specified in the SRFI. Using it avoids the described problems. +@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 @@ -2095,10 +2132,10 @@ 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. +Conversion is locale-dependent on systems that support it +(@pxref{Accessing Locale Information}). @xref{Locales, +@code{setlocale}}, for information on how to change the current +locale. @node SRFI-19 String to date @@ -2219,9 +2256,10 @@ 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. +Conversion is locale-dependent on systems that support it +(@pxref{Accessing Locale Information}). @xref{Locales, +@code{setlocale}}, for information on how to change the current +locale. @end defun diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 21c354c7b..5a4365ff5 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,17 @@ +2007-02-06 Clinton Ebadi <clinton@unknownlamer.org> + + * gds-scheme.el (gds-display-results): Use save-selected-window + instead of switching to other-window in order to return to the + proper window in frames with more than two windows. + +2007-01-17 Neil Jerram <neil@ossau.uklinux.net> + + * gds-scheme.el (gds-display-results): Add another binding for + gds-show-last-stack (RET). + (scheme-mode-map): And another: C-h S. + (scheme-mode-map): And an alternative C-h G binding for + gds-apropos, as we probably should not be using C-h C-g. + 2006-11-02 Neil Jerram <neil@ossau.uklinux.net> * gds-scheme.el (gds-choose-client): Change assq to memq, so that diff --git a/emacs/gds-scheme.el b/emacs/gds-scheme.el index 134e80592..a03a07ba5 100755 --- a/emacs/gds-scheme.el +++ b/emacs/gds-scheme.el @@ -382,38 +382,39 @@ region's code." '(nil . "*Guile Evaluation*")))) (helpp (car helpp+bufname))) (let ((buf (get-buffer-create (cdr helpp+bufname)))) - (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) - (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) - (other-window 1)))) + (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." @@ -1007,6 +1008,8 @@ return the one that they chose." (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) (define-key scheme-mode-map "\C-x " 'gds-set-breakpoint) diff --git a/guile-config/ChangeLog b/guile-config/ChangeLog index de7091980..6156dc812 100644 --- a/guile-config/ChangeLog +++ b/guile-config/ChangeLog @@ -1,3 +1,9 @@ +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" diff --git a/guile-config/Makefile.am b/guile-config/Makefile.am index be61fcdba..4a2d9ba4f 100644 --- a/guile-config/Makefile.am +++ b/guile-config/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with Automake to create Makefile.in ## Jim Blandy <jimb@red-bean.com> --- September 1997 ## -## Copyright (C) 1998, 1999, 2001, 2006 Free Software Foundation, Inc. +## Copyright (C) 1998, 1999, 2001, 2006, 2007 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -35,7 +35,7 @@ aclocal_DATA = guile.m4 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|@-bindir-@|${bindir}|' \ -e s:@-GUILE_VERSION-@:${GUILE_VERSION}: chmod +x guile-config.tmp mv guile-config.tmp guile-config diff --git a/guile-readline/ChangeLog b/guile-readline/ChangeLog index b7bddd59f..51979c783 100644 --- a/guile-readline/ChangeLog +++ b/guile-readline/ChangeLog @@ -1,3 +1,8 @@ +2007-01-19 Han-Wen Nienhuys <hanwen@lilypond.org> + + * readline.c: terminate option list with NULL. + (scm_init_readline): fix CVS mess-up. + 2006-10-06 Neil Jerram <neil@ossau.uklinux.net> * ice-9/readline.scm (new-input-prompt): Renamed from "prompt". diff --git a/guile-readline/readline.c b/guile-readline/readline.c index 4eab67582..4d2be7302 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -52,7 +52,8 @@ scm_t_option scm_readline_opts[] = { { SCM_OPTION_INTEGER, "history-length", 200, "History length." }, { SCM_OPTION_INTEGER, "bounce-parens", 500, - "Time (ms) to show matching opening parenthesis (0 = off)."} + "Time (ms) to show matching opening parenthesis (0 = off)."}, + { 0 } }; extern void stifle_history (int max); @@ -64,7 +65,6 @@ SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0, { SCM ans = scm_options (setting, scm_readline_opts, - SCM_N_READLINE_OPTIONS, FUNC_NAME); stifle_history (SCM_HISTORY_LENGTH); return ans; @@ -573,8 +573,7 @@ scm_init_readline () reentry_barrier_mutex = scm_permanent_object (scm_make_mutex ()); scm_init_opts (scm_readline_options, - scm_readline_opts, - SCM_N_READLINE_OPTIONS); + scm_readline_opts); init_bouncing_parens(); scm_add_feature ("readline"); #endif /* HAVE_RL_GETC_FUNCTION */ diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index f50827ef8..f3848f1e0 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,63 @@ +2007-02-18 Neil Jerram <neil@ossau.uklinux.net> + + * gds-client.scm (connect-to-gds): Break generation of client name + into ... + (client-name): New procedure. + (client-name): Put something from (program-arguments) in the + client name that GDS displays in Emacs. + (connect-to-gds, client-name): Add application-name arg to allow + caller to specify client name. + +2007-02-09 Ludovic Courtès <ludovic.courtes@laas.fr> + + * Makefile.am (ice9_sources): Added `i18n.scm'. + +2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr> + + * i18n.scm: Use `(ice-9 optargs)'. Don't export `LC_*_MASK' + variables. Added new exports. + (locale-encoding, locale-day-short, locale-day, + locale-month-short, locale-month, locale-am-string, + locale-pm-string, locale-date+time-format, locale-date-format, + locale-time-format, locale-time+am/pm-format, locale-era, + locale-era-year, locale-era-date+time-format, + locale-era-date-format, locale-era-time-format, + locale-currency-symbol, locale-monetary-fractional-digits, + locale-monetary-positive-sign, locale-monetary-negative-sign, + locale-monetary-decimal-point, + locale-monetary-thousands-separator, + locale-monetary-digit-grouping, + locale-currency-symbol-precedes-positive?, + locale-currency-symbol-precedes-negative?, + locale-positive-separated-by-space?, + locale-negative-separated-by-space?, + locale-positive-sign-position, locale-negative-sign-position, + %number-integer-part, add-monetary-sign+currency, + monetary-amount->locale-string, locale-digit-grouping, + locale-decimal-point, locale-thousands-separator, + number->locale-string, locale-yes-regexp, locale-no-regexp): New + procedures. + (define-vector-langinfo-mapping, define-simple-langinfo-mapping, + define-monetary-langinfo-mapping): New macros. + +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 @@ -106,7 +166,7 @@ where `futures' should become `threads' from Marius' change of 2006-01-29. -2006-03-04 Ludovic Courtès <ludovic.courtes@laas.fr> +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. @@ -128,7 +188,7 @@ * 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. + Ludovic Courtès for pointing this problem out. * stack-catch.scm (stack-catch): Use catch pre-unwind handler instead of lazy-catch. @@ -136,7 +196,7 @@ * 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> +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. @@ -152,7 +212,7 @@ 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.) + do the read, if set. (Thanks to Ludovic Courtès for the patch.) 2005-12-14 Neil Jerram <neil@ossau.uklinux.net> @@ -168,7 +228,7 @@ * boot-9.scm (%cond-expand-features): Add srfi-61. -2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr> +2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr> * networking.scm (sockaddr:flowinfo, sockaddr:scopeid): New functions. @@ -1197,7 +1257,7 @@ 2002-01-12 Marius Vollmer <mvo@zagadka.ping.de> - More options for pretty-print. Thanks to Matthias Köppe! + 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 @@ -1274,7 +1334,7 @@ * session.scm (arity): Use new `arglist' procedure property to present a more detailed argument list. - Thanks to Matthias Köppe! + Thanks to Matthias Köppe! 2001-09-07 Thien-Thi Nguyen <ttn@revel.glug.org> @@ -1493,12 +1553,12 @@ * 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! + 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! + Köppe! 2001-06-05 Marius Vollmer <mvo@zagadka.ping.de> @@ -1603,7 +1663,7 @@ * 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! + getting the syntax transformer. Thanks to Matthias Köppe! 2001-05-21 Marius Vollmer <mvo@zagadka.ping.de> @@ -1713,7 +1773,7 @@ * 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! + ("printer") for each produced value. Thanks to Matthias Köppe! 2001-05-14 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> @@ -2234,7 +2294,7 @@ 2000-08-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se> * format.scm (format:obj->str): Made tail-recursive. (Thanks to - Matthias Köppe.) + Matthias Köppe.) 2000-08-13 Mikael Djurfeldt <mdj@linnaeus.mit.edu> @@ -2333,7 +2393,7 @@ 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.) + module graph. (Thanks to Matthias Köppe.) 2000-06-20 Mikael Djurfeldt <mdj@thalamus.nada.kth.se> @@ -4795,3 +4855,6 @@ Fri Apr 19 13:53:08 1996 Tom Lord <lord@beehive> * The more things change... +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am index 0eb1ac8f2..454b117cc 100644 --- a/ice-9/Makefile.am +++ b/ice-9/Makefile.am @@ -24,18 +24,19 @@ AUTOMAKE_OPTIONS = gnu SUBDIRS = debugger debugging # 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 \ +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 i18n.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 subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9 diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index b50ae2911..e8f5bb691 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006 +;;;; 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 @@ -3313,13 +3313,11 @@ ;; numbers, which are the numbers of the SRFIs to be loaded on startup. ;; (define (use-srfis srfis) - (let lp ((s srfis)) - (if (pair? s) - (let* ((srfi (string->symbol - (string-append "srfi-" (number->string (car s))))) - (mod-i (resolve-interface (list 'srfi srfi)))) - (module-use! (current-module) mod-i) - (lp (cdr s)))))) + (process-use-modules + (map (lambda (num) + (list (list 'srfi (string->symbol + (string-append "srfi-" (number->string num)))))) + srfis))) @@ -3387,30 +3385,38 @@ ;; Use some convenient modules (in reverse order) - (if (provided? 'regex) - (module-use! guile-user-module (resolve-interface '(ice-9 regex)))) - (if (provided? 'threads) - (module-use! guile-user-module (resolve-interface '(ice-9 threads)))) + (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))) - (module-use! guile-user-module (resolve-interface '(ice-9 session))) - (module-use! guile-user-module (resolve-interface '(ice-9 debug))) - ;; so that builtin bindings will be checked first - (module-use! guile-user-module (resolve-interface '(ice-9 r5rs))) - (module-use! guile-user-module (resolve-interface '(guile))) - (set-current-module guile-user-module) + ;; 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") - (,SIGBUS . "Bad memory access (bus 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 diff --git a/ice-9/gds-client.scm b/ice-9/gds-client.scm index 8c7bdc742..7e6e524e5 100755 --- a/ice-9/gds-client.scm +++ b/ice-9/gds-client.scm @@ -170,7 +170,7 @@ (safely-handle-nondebug-protocol protocol) (loop (gds-debug-read)))))))) -(define (connect-to-gds) +(define (connect-to-gds . application-name) (or gds-port (begin (set! gds-port @@ -190,7 +190,19 @@ s) (lambda _ #f))) (error "Couldn't connect to GDS by TCP or Unix domain socket"))) - (write-form (list 'name (getpid) (format #f "PID ~A" (getpid))))))) + (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 diff --git a/ice-9/i18n.scm b/ice-9/i18n.scm index e782ee21a..e7c116e53 100644 --- a/ice-9/i18n.scm +++ b/ice-9/i18n.scm @@ -1,6 +1,6 @@ ;;;; i18n.scm --- internationalization support -;;;; Copyright (C) 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 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 @@ -29,18 +29,10 @@ ;;; Code: (define-module (ice-9 i18n) + :use-module (ice-9 optargs) :export (;; `locale' type make-locale locale? - - ;; locale category masks (standard) - LC_ALL_MASK - LC_COLLATE_MASK LC_CTYPE_MASK LC_MESSAGES_MASK - LC_MONETARY_MASK LC_NUMERIC_MASK LC_TIME_MASK - - ;; locale category masks (non-standard) - LC_PAPER_MASK LC_NAME_MASK LC_ADDRESS_MASK - LC_TELEPHONE_MASK LC_MEASUREMENT_MASK - LC_IDENTIFICATION_MASK + %global-locale ;; text collation string-locale<? string-locale>? @@ -54,11 +46,373 @@ string-locale-downcase string-locale-upcase ;; reading numbers - locale-string->integer locale-string->inexact)) + locale-string->integer locale-string->inexact + + ;; charset/encoding + locale-encoding + + ;; days and months + locale-day-short locale-day locale-month-short locale-month + + ;; date and time + locale-am-string locale-pm-string + locale-date+time-format locale-date-format locale-time-format + locale-time+am/pm-format + locale-era locale-era-year + locale-era-date-format locale-era-date+time-format + locale-era-time-format + + ;; monetary + locale-currency-symbol + locale-monetary-decimal-point locale-monetary-thousands-separator + locale-monetary-grouping locale-monetary-fractional-digits + locale-currency-symbol-precedes-positive? + locale-currency-symbol-precedes-negative? + locale-positive-separated-by-space? + locale-negative-separated-by-space? + locale-monetary-positive-sign locale-monetary-negative-sign + locale-positive-sign-position locale-negative-sign-position + monetary-amount->locale-string + + ;; number formatting + locale-digit-grouping locale-decimal-point + locale-thousands-separator + number->locale-string + + ;; miscellaneous + locale-yes-regexp locale-no-regexp)) (load-extension "libguile-i18n-v-0" "scm_init_i18n") + +;;; +;;; Charset/encoding. +;;; + +(define (locale-encoding . locale) + (apply nl-langinfo CODESET locale)) + + +;;; +;;; Months and days. +;;; + +;; Helper macro: Define a procedure named NAME that maps its argument to +;; NL-ITEMS (when `nl-langinfo' is provided) or DEFAULTS (when `nl-langinfo' +;; is not provided). +(define-macro (define-vector-langinfo-mapping name nl-items defaults) + (let* ((item-count (length nl-items)) + (defines (if (provided? 'nl-langinfo) + `(define %nl-items (vector #f ,@nl-items)) + `(define %defaults (vector #f ,@defaults)))) + (make-body (lambda (result) + `(if (and (integer? item) (exact? item)) + (if (and (>= item 1) (<= item ,item-count)) + ,result + (throw 'out-of-range "out of range" item)) + (throw 'wrong-type-arg "wrong argument type" item))))) + `(define (,name item . locale) + ,defines + ,(make-body (if (provided? 'nl-langinfo) + '(apply nl-langinfo (vector-ref %nl-items item) locale) + '(vector-ref %defaults item)))))) + + +(define-vector-langinfo-mapping locale-day-short + (ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7) + ("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")) + +(define-vector-langinfo-mapping locale-day + (DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7) + ("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) + +(define-vector-langinfo-mapping locale-month-short + (ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6 + ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12) + ("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) + +(define-vector-langinfo-mapping locale-month + (MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8 MON_9 MON_10 MON_11 MON_12) + ("January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December")) + + + +;;; +;;; Date and time. +;;; + +;; Helper macro: Define a procedure NAME that gets langinfo item ITEM. +(define-macro (define-simple-langinfo-mapping name item default) + (let ((body (if (and (provided? 'nl-langinfo) (defined? item)) + `(apply nl-langinfo ,item locale) + default))) + `(define (,name . locale) + ,body))) + +(define-simple-langinfo-mapping locale-am-string + AM_STR "AM") +(define-simple-langinfo-mapping locale-pm-string + PM_STR "PM") +(define-simple-langinfo-mapping locale-date+time-format + D_T_FMT "%a %b %e %H:%M:%S %Y") +(define-simple-langinfo-mapping locale-date-format + D_FMT "%m/%d/%y") +(define-simple-langinfo-mapping locale-time-format + T_FMT "%H:%M:%S") +(define-simple-langinfo-mapping locale-time+am/pm-format + T_FMT_AMPM "%I:%M:%S %p") +(define-simple-langinfo-mapping locale-era + ERA "") +(define-simple-langinfo-mapping locale-era-year + ERA_YEAR "") +(define-simple-langinfo-mapping locale-era-date+time-format + ERA_D_T_FMT "") +(define-simple-langinfo-mapping locale-era-date-format + ERA_D_FMT "") +(define-simple-langinfo-mapping locale-era-time-format + ERA_T_FMT "") + + + +;;; +;;; Monetary information. +;;; + +(define-macro (define-monetary-langinfo-mapping name local-item intl-item + default/local default/intl) + (let ((body + (let ((intl (if (and (provided? 'nl-langinfo) (defined? intl-item)) + `(apply nl-langinfo ,intl-item locale) + default/intl)) + (local (if (and (provided? 'nl-langinfo) (defined? local-item)) + `(apply nl-langinfo ,local-item locale) + default/local))) + `(if intl? ,intl ,local)))) + + `(define (,name intl? . locale) + ,body))) + +;; FIXME: How can we use ALT_DIGITS? +(define-monetary-langinfo-mapping locale-currency-symbol + CRNCYSTR INT_CURR_SYMBOL + "-" "") +(define-monetary-langinfo-mapping locale-monetary-fractional-digits + FRAC_DIGITS INT_FRAC_DIGITS + 2 2) + +(define-simple-langinfo-mapping locale-monetary-positive-sign + POSITIVE_SIGN "+") +(define-simple-langinfo-mapping locale-monetary-negative-sign + NEGATIVE_SIGN "-") +(define-simple-langinfo-mapping locale-monetary-decimal-point + MON_DECIMAL_POINT "") +(define-simple-langinfo-mapping locale-monetary-thousands-separator + MON_THOUSANDS_SEP "") +(define-simple-langinfo-mapping locale-monetary-digit-grouping + MON_GROUPING '()) + +(define-monetary-langinfo-mapping locale-currency-symbol-precedes-positive? + P_CS_PRECEDES INT_P_CS_PRECEDES + #t #t) +(define-monetary-langinfo-mapping locale-currency-symbol-precedes-negative? + N_CS_PRECEDES INT_N_CS_PRECEDES + #t #t) + + +(define-monetary-langinfo-mapping locale-positive-separated-by-space? + ;; Whether a space should be inserted between a positive amount and the + ;; currency symbol. + P_SEP_BY_SPACE INT_P_SEP_BY_SPACE + #t #t) +(define-monetary-langinfo-mapping locale-negative-separated-by-space? + ;; Whether a space should be inserted between a negative amount and the + ;; currency symbol. + N_SEP_BY_SPACE INT_N_SEP_BY_SPACE + #t #t) + +(define-monetary-langinfo-mapping locale-positive-sign-position + ;; Position of the positive sign wrt. currency symbol and quantity in a + ;; monetary amount. + P_SIGN_POSN INT_P_SIGN_POSN + 'unspecified 'unspecified) +(define-monetary-langinfo-mapping locale-negative-sign-position + ;; Position of the negative sign wrt. currency symbol and quantity in a + ;; monetary amount. + N_SIGN_POSN INT_N_SIGN_POSN + 'unspecified 'unspecified) + + +(define (%number-integer-part int grouping separator) + ;; Process INT (a string denoting a number's integer part) and return a new + ;; string with digit grouping and separators according to GROUPING (a list, + ;; potentially circular) and SEPARATOR (a string). + + ;; Process INT from right to left. + (let loop ((int int) + (grouping grouping) + (result '())) + (cond ((string=? int "") (apply string-append result)) + ((null? grouping) (apply string-append int result)) + (else + (let* ((len (string-length int)) + (cut (min (car grouping) len))) + (loop (substring int 0 (- len cut)) + (cdr grouping) + (let ((sub (substring int (- len cut) len))) + (if (> len cut) + (cons* separator sub result) + (cons sub result))))))))) + +(define (add-monetary-sign+currency amount figure intl? locale) + ;; Add a sign and currency symbol around FIGURE. FIGURE should be a + ;; formatted unsigned amount (a string) representing AMOUNT. + (let* ((positive? (> amount 0)) + (sign + (cond ((> amount 0) (locale-monetary-positive-sign locale)) + ((< amount 0) (locale-monetary-negative-sign locale)) + (else ""))) + (currency (locale-currency-symbol intl? locale)) + (currency-precedes? + (if positive? + locale-currency-symbol-precedes-positive? + locale-currency-symbol-precedes-negative?)) + (separated? + (if positive? + locale-positive-separated-by-space? + locale-negative-separated-by-space?)) + (sign-position + (if positive? + locale-positive-sign-position + locale-negative-sign-position)) + (currency-space + (if (separated? intl? locale) " " "")) + (append-currency + (lambda (amt) + (if (currency-precedes? intl? locale) + (string-append currency currency-space amt) + (string-append amt currency-space currency))))) + + (case (sign-position intl? locale) + ((parenthesize) + (string-append "(" (append-currency figure) ")")) + ((sign-before) + (string-append sign (append-currency figure))) + ((sign-after unspecified) + ;; following glibc's recommendation for `unspecified'. + (if (currency-precedes? intl? locale) + (string-append currency currency-space sign figure) + (string-append figure currency-space currency sign))) + ((sign-before-currency-symbol) + (if (currency-precedes? intl? locale) + (string-append sign currency currency-space figure) + (string-append figure currency-space sign currency))) ;; unlikely + ((sign-after-currency-symbol) + (if (currency-precedes? intl? locale) + (string-append currency sign currency-space figure) + (string-append figure currency-space currency sign))) + (else + (error "unsupported sign position" (sign-position intl? locale)))))) + + +(define* (monetary-amount->locale-string amount intl? + #:optional (locale %global-locale)) + "Convert @var{amount} (an inexact) into a string according to the cultural +conventions of either @var{locale} (a locale object) or the current locale. +If @var{intl?} is true, then the international monetary format for the given +locale is used." + + (let* ((fraction-digits + (or (locale-monetary-fractional-digits intl? locale) 2)) + (decimal-part + (lambda (dec) + (if (or (string=? dec "") (eq? 0 fraction-digits)) + "" + (string-append (locale-monetary-decimal-point locale) + (if (< fraction-digits (string-length dec)) + (substring dec 0 fraction-digits) + dec))))) + + (external-repr (number->string (if (> amount 0) amount (- amount)))) + (int+dec (string-split external-repr #\.)) + (int (car int+dec)) + (dec (decimal-part (if (null? (cdr int+dec)) + "" + (cadr int+dec)))) + (grouping (locale-monetary-digit-grouping locale)) + (separator (locale-monetary-thousands-separator locale))) + + (add-monetary-sign+currency amount + (string-append + (%number-integer-part int grouping + separator) + dec) + intl? locale))) + + + +;;; +;;; Number formatting. +;;; + +(define-simple-langinfo-mapping locale-digit-grouping + GROUPING '()) +(define-simple-langinfo-mapping locale-decimal-point + RADIXCHAR ".") +(define-simple-langinfo-mapping locale-thousands-separator + THOUSEP "") + +(define* (number->locale-string number + #:optional (fraction-digits #t) + (locale %global-locale)) + "Convert @var{number} (an inexact) into a string according to the cultural +conventions of either @var{locale} (a locale object) or the current locale. +Optionally, @var{fraction-digits} may be bound to an integer specifying the +number of fractional digits to be displayed." + + (let* ((sign + (cond ((> number 0) "") + ((< number 0) "-") + (else ""))) + (decimal-part + (lambda (dec) + (if (or (string=? dec "") (eq? 0 fraction-digits)) + "" + (string-append (locale-decimal-point locale) + (if (and (integer? fraction-digits) + (< fraction-digits + (string-length dec))) + (substring dec 0 fraction-digits) + dec)))))) + + (let* ((external-repr (number->string (if (> number 0) + number + (- number)))) + (int+dec (string-split external-repr #\.)) + (int (car int+dec)) + (dec (decimal-part (if (null? (cdr int+dec)) + "" + (cadr int+dec)))) + (grouping (locale-digit-grouping locale)) + (separator (locale-thousands-separator locale))) + + (string-append sign + (%number-integer-part int grouping separator) + dec)))) + + +;;; +;;; Miscellaneous. +;;; + +(define-simple-langinfo-mapping locale-yes-regexp + YESEXPR "^[yY]") +(define-simple-langinfo-mapping locale-no-regexp + NOEXPR "^[nN]") + +;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them. + ;;; Local Variables: ;;; coding: latin-1 diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8ba446c6c..2762daec6 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,16 +1,262 @@ +2007-02-19 Neil Jerram <neil@ossau.uklinux.net> + + * Makefile.am (noinst_HEADERS): Add private-options.h, so that it + is included in the distribution. + +2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr> + + * i18n.c: Include "libguile/threads.h" and "libguile/posix.h" + unconditionally. Include <langinfo.h> and <nl_types.h> when + available. + (SCM_I18N_STRINGIFY, SCM_LOCALE_CATEGORY_MASK, + SCM_LIST_OR_INTEGER_P): New macros. + (LC_*_MASK): When `USE_GNU_LOCALE_API' is undefined, define them + as powers of two instead of `(1 << LC_*)'. + (scm_i_locale_free): New function/macro. + (scm_global_locale): New global variable. + (smob_locale_free): Use `scm_i_locale_free ()'. + (smob_locale_mark): Check whether the SMOB is `%global-locale'. + (get_current_locale_settings): Return `EINVAL' instead of `errno' + when `setlocale' fails. + (restore_locale_settings): Likewise. + (install_locale_categories): Likewise. + (install_locale): Likewise. Stop the locale stack traversal when + all categories have been handled. + (get_current_locale, category_to_category_mask, + category_list_to_category_mask): New function. + (scm_make_locale): Use them. Accept both lists of `LC_*' values + and single `LC_*' values as the first argument. Handle the case + where BASE_LOCALE is `%global-locale'. When `USE_GNU_LOCALE_API', + duplicate C_BASE_LOCALE before using it. + (scm_nl_langinfo, define_langinfo_items): New functions. + (scm_init_i18n): When `HAVE_NL_LANGINFO', add feature + `nl-langinfo' and invoke `define_langinfo_items ()'. + * i18n.h (scm_global_locale, scm_nl_langinfo): New declarations. + * posix.c: Include <xlocale.h> when available. + (scm_i_locale_mutex): Always define it. Statically initialized. + (scm_set_locale): Invoke `scm_i_to_lc_category ()' before + acquiring the locale mutex. + (scm_init_posix): No longer initialize SCM_I_LOCALE_MUTEX here. + +2007-01-25 Han-Wen Nienhuys <hanwen@lilypond.org> + + * vector.c: remove comment as per kryde's request. + +2007-01-22 Han-Wen Nienhuys <hanwen@lilypond.org> + + * vectors.c (s_scm_vector_move_right_x): complain about naming. + + * srcprop.c: regularize comments. + + * eval.c: remove superfluous ifndef DEVAL. + + * private-options.h: idem. + + * eval.i.c: copyright nitpicking. + + * eval.c: distangle. move duplicate code to eval.i.c and include + twice. + + * eval.i.c: new file. + + * backtrace.c, debug.c, debug.h, deprecation.c, eq.c, eval.c + eval.h, gsubr.c, init.c, macros.c, print.c, print.h, read.c, + read.h, stacks.c, symbols.c, throw.c: use private-options.h + + * private-options.h: new file: contain hardcoded option + definitions. + + * private-gc.h: add FSF header. + +2007-01-19 Han-Wen Nienhuys <hanwen@lilypond.org> + + * debug.h (SCM_RESET_DEBUG_MODE): switch to debugging if + memoize-symbol is set. + + * eval.h (SCM_MEMOIZE_HDLR): add macros for memoize symbol trap. + + * eval.c (CEVAL): add memoize_symbol trap. + + * options.c (scm_options_try): new function. This allows error + reporting before changing options in a critical section. + + * 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. + + * read.c: idem. + + * print.c: idem. + + * eval.c: terminate option lists with 0. + + * options.c: remove n (for length) from scm_option_X + functions. Detect option list length by looking for NULL name. + +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-18 Han-Wen Nienhuys <hanwen@lilypond.org> + + * throw.c (scm_ithrow): more refined error message: print symbols + too. + +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-10 Han-Wen Nienhuys <hanwen@lilypond.org> + + * throw.c (scm_ithrow): print out key symbol and string arguments + when error happens inside a critical section, and document why. + +2007-01-06 Han-Wen Nienhuys <hanwen@lilypond.org> + + * read.c (s_scm_read_hash_extend): document #f argument to + read-hash-extend. + +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. + +2007-01-03 Han-Wen Nienhuys <hanwen@lilypond.org> + + * gc.c (s_scm_gc_stats): return an entry for total-cells-allocated + too. + (gc_update_stats): update scm_gc_cells_allocated_acc too. + +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 Gyula Szavai). This allows the use of + 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 - Gyula Szavai). + 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 diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 6e1fa8634..3944f2e46 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -182,7 +182,7 @@ noinst_HEADERS = convert.i.c \ srfi-4.i.c \ quicksort.i.c \ win32-uname.h win32-dirent.h win32-socket.h \ - private-gc.h + private-gc.h private-options.h libguile_la_DEPENDENCIES = @LIBLOBJS@ libguile_la_LIBADD = @LIBLOBJS@ @@ -283,7 +283,7 @@ SUFFIXES = .x .doc .c.x: ./guile-snarf -o $@ $< $(snarfcppopts) .c.doc: - -(test -n "${AWK+set}" || AWK="@AWK@"; ${AWK} -f ./guile-func-name-check $<) + -$(AWK) -f ./guile-func-name-check $< (./guile-snarf-docs $(snarfcppopts) $< | \ ./guile_filter_doc_snarfage$(EXEEXT) --filter-snarfage) > $@ || { rm $@; false; } diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 38d7a8382..a8bc12059 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -47,6 +47,7 @@ #include "libguile/lang.h" #include "libguile/backtrace.h" #include "libguile/filesys.h" +#include "libguile/private-options.h" /* {Error reporting and backtraces} * diff --git a/libguile/debug.c b/libguile/debug.c index 653c458a2..280e92b7d 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -42,8 +42,11 @@ #include "libguile/validate.h" #include "libguile/debug.h" + +#include "libguile/private-options.h" + /* {Run time control of the debugging evaluator} */ @@ -59,10 +62,10 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, scm_dynwind_begin (0); scm_dynwind_critical_section (SCM_BOOL_F); - ans = scm_options (setting, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME); + ans = scm_options (setting, scm_debug_opts, 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_options (ans, scm_debug_opts, FUNC_NAME); SCM_OUT_OF_RANGE (1, setting); } SCM_RESET_DEBUG_MODE; @@ -74,6 +77,7 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, } #undef FUNC_NAME + static void with_traps_before (void *data) { @@ -112,7 +116,6 @@ SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0, #undef FUNC_NAME - SCM_SYMBOL (scm_sym_procname, "procname"); SCM_SYMBOL (scm_sym_dots, "..."); SCM_SYMBOL (scm_sym_source, "source"); @@ -526,7 +529,7 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0, void scm_init_debug () { - scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS); + scm_init_opts (scm_debug_options, scm_debug_opts); scm_tc16_memoized = scm_make_smob_type ("memoized", 0); scm_set_smob_print (scm_tc16_memoized, memoized_print); diff --git a/libguile/debug.h b/libguile/debug.h index c292004a3..79afa4d53 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -42,28 +42,13 @@ /* 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; +SCM_API int scm_check_memoize_p; #define SCM_RESET_DEBUG_MODE \ do {\ @@ -73,8 +58,10 @@ do {\ && 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_check_memoize_p = (SCM_MEMOIZE_P)\ + && scm_is_true (SCM_MEMOIZE_HDLR);\ scm_debug_mode_p = SCM_DEVAL_P\ - || scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\ + || scm_check_memoize_p || scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\ } while (0) /* {Evaluator} diff --git a/libguile/deprecated.h b/libguile/deprecated.h index bbd8bc07a..9a0862c3e 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -5,7 +5,7 @@ #ifndef SCM_DEPRECATED_H #define SCM_DEPRECATED_H -/* Copyright (C) 2003,2004, 2005, 2006 Free Software Foundation, Inc. +/* 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 @@ -164,7 +164,7 @@ SCM_API SCM scm_make_gsubr_with_generic (const char *name, SCM (*fcn)(), SCM *gf); -extern SCM scm_create_hook (const char* name, int n_args); +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) diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 6e314ddd9..22073033e 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -31,6 +31,9 @@ #include "libguile/strings.h" #include "libguile/ports.h" +#include "libguile/private-options.h" + + /* Windows defines. */ #ifdef __MINGW32__ #define vsnprintf _vsnprintf diff --git a/libguile/eq.c b/libguile/eq.c index 7c7e76d0e..ebc91c93b 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -36,6 +36,9 @@ #include "libguile/validate.h" #include "libguile/eq.h" + +#include "libguile/private-options.h" + #ifdef HAVE_STRING_H diff --git a/libguile/eval.c b/libguile/eval.c index dcbd1ac7d..95dd95974 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -20,12 +20,6 @@ #define _GNU_SOURCE -/* 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. */ @@ -35,8 +29,6 @@ #include "libguile/__scm.h" -#ifndef DEVAL - /* This blob per the Autoconf manual (under "Particular Functions"). */ #if HAVE_ALLOCA_H # include <alloca.h> @@ -90,14 +82,18 @@ void *alloca (size_t); #include "libguile/vectors.h" #include "libguile/eval.h" +#include "libguile/private-options.h" + 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); +static void ceval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol); +static SCM ceval (SCM x, SCM env); +static SCM deval (SCM x, SCM env); @@ -1235,7 +1231,7 @@ scm_m_define (SCM expr, SCM env) SCM tmp = value; while (SCM_MACROP (tmp)) tmp = SCM_MACRO_CODE (tmp); - if (SCM_CLOSUREP (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); @@ -2555,6 +2551,7 @@ scm_unmemocar (SCM form, SCM env) 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_memoize_symbol, "memoize-symbol"); SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); SCM_SYMBOL (sym_instead, "instead"); @@ -2581,46 +2578,27 @@ scm_badargsp (SCM formals, SCM args) -/* The evaluator contains a plethora of EVAL symbols. This is an attempt at - * explanation. +/* The evaluator contains a plethora of EVAL symbols. * - * 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 + * SCM_I_XEVAL 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> ...)', + * This macro uses ceval or deval depending on its 3rd argument. + * + * SCM_I_XEVALCAR 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): + * This macro uses ceval or deval depending on its 3rd argument. * - * 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 \ @@ -2631,50 +2609,30 @@ static SCM deval (SCM x, SCM env); ? *scm_ilookup ((x), (env)) \ : SCM_I_EVALIM2(x)) -#define SCM_I_XEVAL(x, env) \ +#define SCM_I_XEVAL(x, env, debug_p) \ (SCM_IMP (x) \ ? SCM_I_EVALIM2 (x) \ : (SCM_VARIABLEP (x) \ ? SCM_VARIABLE_REF (x) \ : (scm_is_pair (x) \ - ? (scm_debug_mode_p \ + ? (debug_p \ ? deval ((x), (env)) \ : ceval ((x), (env))) \ : (x)))) -#define SCM_I_XEVALCAR(x, env) \ +#define SCM_I_XEVALCAR(x, env, debug_p) \ (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 \ + ? (debug_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; @@ -2935,25 +2893,7 @@ lazy_memoize_variable (const SCM symbol, const SCM environment) 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; + return SCM_I_XEVALCAR (pair, env, scm_debug_mode_p); } @@ -2980,70 +2920,13 @@ scm_eval_body (SCM code, SCM env) } } else - SCM_I_XEVAL (SCM_CAR (code), env); + SCM_I_XEVAL (SCM_CAR (code), env, scm_debug_mode_p); code = next; next = SCM_CDR (code); } - return SCM_I_XEVALCAR (code, env); + return SCM_I_XEVALCAR (code, env, scm_debug_mode_p); } -#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 && 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 @@ -3061,11 +2944,13 @@ int scm_debug_mode_p; int scm_check_entry_p; int scm_check_apply_p; int scm_check_exit_p; +int scm_check_memoize_p; long scm_eval_stack; scm_t_option scm_eval_opts[] = { - { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." } + { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }, + { 0 } }; scm_t_option scm_debug_opts[] = { @@ -3086,11 +2971,22 @@ scm_t_option scm_debug_opts[] = { { 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_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." }, + { 0 }, }; + +/* + * this ordering is awkward and illogical, but we maintain it for + * compatibility. --hwn + */ 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." }, @@ -3098,9 +2994,13 @@ scm_t_option scm_evaluator_trap_table[] = { { 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_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." }, + { SCM_OPTION_BOOLEAN, "memoize-symbol", 0, "Trap when memoizing a symbol." }, + { SCM_OPTION_SCM, "memoize-symbol-handler", (unsigned long)SCM_BOOL_F, "The handler for memoization." }, + { 0 } }; + SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, (SCM setting), "Option interface for the evaluation options. Instead of using\n" @@ -3114,7 +3014,6 @@ SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 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 (); @@ -3130,11 +3029,16 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, #define FUNC_NAME s_scm_evaluator_traps { SCM ans; + + + scm_options_try (setting, + scm_evaluator_trap_table, + FUNC_NAME, 1); 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; @@ -3143,1502 +3047,6 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, #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_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_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_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_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_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_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_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_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_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 @@ -4749,343 +3157,11 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, } #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_UNBNDP (arg1)) - scm_wrong_num_args (proc); - if (scm_is_null (args)) - args = SCM_UNDEFINED; - else - { - if (! 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_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_UNBNDP (arg1)) - scm_wrong_num_args (proc); - else - RETURN (SCM_SUBRF (proc) ()); - case scm_tc7_subr_1: - if (SCM_UNBNDP (arg1)) - scm_wrong_num_args (proc); - case scm_tc7_subr_1o: - if (!scm_is_null (args)) - scm_wrong_num_args (proc); - else - RETURN (SCM_SUBRF (proc) (arg1)); - case scm_tc7_dsubr: - if (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_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_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_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_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 @@ -5213,19 +3289,19 @@ call_dsubr_1 (SCM proc, SCM arg1) { if (SCM_I_INUMP (arg1)) { - RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (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)))); + 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)))); + 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)))); + 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))); @@ -5870,7 +3946,7 @@ 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); + return SCM_I_XEVAL (exp, env, scm_debug_mode_p); } SCM @@ -5880,7 +3956,7 @@ scm_i_eval (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); + return SCM_I_XEVAL (exp, env, scm_debug_mode_p); } SCM @@ -5964,46 +4040,9 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0, */ #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 +#include "eval.i.c" +#undef DEVAL +#include "eval.i.c" void @@ -6013,11 +4052,9 @@ scm_init_eval () scm_i_pthread_mutexattr_recursive); scm_init_opts (scm_evaluator_traps, - scm_evaluator_trap_table, - SCM_N_EVALUATOR_TRAPS); + scm_evaluator_trap_table); scm_init_opts (scm_eval_options_interface, - scm_eval_opts, - SCM_N_EVAL_OPTIONS); + scm_eval_opts); scm_tc16_promise = scm_make_smob_type ("promise", 0); scm_set_smob_print (scm_tc16_promise, promise_print); @@ -6036,10 +4073,9 @@ scm_init_eval () scm_add_feature ("delay"); } -#endif /* !DEVAL */ - /* Local Variables: c-file-style: "gnu" End: */ + diff --git a/libguile/eval.h b/libguile/eval.h index 7d856a00b..247cf164e 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -32,25 +32,6 @@ /* {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 diff --git a/libguile/eval.i.c b/libguile/eval.i.c new file mode 100644 index 000000000..c1e1fb62e --- /dev/null +++ b/libguile/eval.i.c @@ -0,0 +1,1942 @@ +/* + * eval.i.c - actual evaluator code for GUILE + * + * Copyright (C) 2002, 03, 04, 05, 06, 07 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +#undef RETURN +#undef ENTER_APPLY +#undef PREP_APPLY +#undef CEVAL +#undef SCM_APPLY +#undef EVAL_DEBUGGING_P + + +#ifdef DEVAL + +/* + This code is specific for the debugging support. + */ + +#define EVAL_DEBUGGING_P 1 +#define CEVAL deval /* Substitute all uses of ceval */ +#define SCM_APPLY scm_dapply +#define PREP_APPLY(p, l) \ +{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; } + +#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) + +#define RETURN(e) do { proc = (e); goto exit; } while (0) + +#ifdef STACK_CHECKING +# ifndef EVAL_STACK_CHECKING +# define EVAL_STACK_CHECKING +# endif /* EVAL_STACK_CHECKING */ +#endif /* STACK_CHECKING */ + + + + +static SCM +deval_args (SCM l, SCM env, SCM proc, SCM *lloc) +{ + SCM *results = lloc; + while (scm_is_pair (l)) + { + const SCM res = SCM_I_XEVALCAR (l, env, 1); + + *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; +} + + +#else /* DEVAL */ + +/* + Code is specific to debugging-less support. + */ + + +#define CEVAL ceval +#define SCM_APPLY scm_apply +#define PREP_APPLY(proc, args) +#define ENTER_APPLY +#define RETURN(x) do { return x; } while (0) +#define EVAL_DEBUGGING_P 0 + +#ifdef STACK_CHECKING +# ifndef NO_CEVAL_STACK_CHECKING +# define EVAL_STACK_CHECKING +# endif +#endif + + + + +static void +ceval_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) + { + ceval_letrec_inits (env, init_forms, init_values_eol); + break; + } + argv[i++] = SCM_I_XEVALCAR (init_forms, env, 0); + 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); + } +} + +static SCM +scm_ceval_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_args (SCM l, SCM env, SCM proc) +{ + return scm_ceval_args (l, env, proc); +} + + + +#endif + + + + +#define EVAL(x, env) SCM_I_XEVAL(x, env, EVAL_DEBUGGING_P) +#define EVALCAR(x, env) SCM_I_XEVALCAR(x, env, EVAL_DEBUGGING_P) + + + +/* 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); + ceval_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_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; +#ifdef DEVAL + if (scm_check_memoize_p && SCM_TRAPS_P) + { + SCM_CLEAR_TRACED_FRAME (debug); + SCM arg1 = scm_make_debugobj (&debug); + SCM retval = SCM_BOOL_T; + SCM_TRAPS_P = 0; + retval = scm_call_4 (SCM_MEMOIZE_HDLR, + scm_sym_memoize_symbol, + arg1, x, env); + + /* + do something with retval? + */ + SCM_TRAPS_P = 1; + } +#endif + } + + 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_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_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_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_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_ceval_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_ceval_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_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_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_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_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_ceval_args (x, env, proc))); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1, + arg2, + scm_ceval_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_ceval_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_ceval_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_ceval_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 +} + + + + +/* 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_UNBNDP (arg1)) + scm_wrong_num_args (proc); + if (scm_is_null (args)) + args = SCM_UNDEFINED; + else + { + if (! 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_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_UNBNDP (arg1)) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) ()); + case scm_tc7_subr_1: + if (SCM_UNBNDP (arg1)) + scm_wrong_num_args (proc); + case scm_tc7_subr_1o: + if (!scm_is_null (args)) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1)); + case scm_tc7_dsubr: + if (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_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_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_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_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 +} + diff --git a/libguile/feature.c b/libguile/feature.c index 1d44a7790..6cd0e54ab 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006 Free Software Foundation, Inc. +/* 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 @@ -76,6 +76,22 @@ scm_set_program_arguments (int argc, char **argv, char *first) 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 + diff --git a/libguile/feature.h b/libguile/feature.h index 58db46422..9c61f8ce8 100644 --- a/libguile/feature.h +++ b/libguile/feature.h @@ -3,7 +3,7 @@ #ifndef SCM_FEATURE_H #define SCM_FEATURE_H -/* Copyright (C) 1995,1996,1999,2000,2001, 2006 Free Software Foundation, Inc. +/* 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 @@ -27,6 +27,7 @@ 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 */ diff --git a/libguile/filesys.c b/libguile/filesys.c index 72b45e92a..1798bb698 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1681,65 +1681,65 @@ scm_init_filesys () scm_dot_string = scm_permanent_object (scm_from_locale_string (".")); #ifdef O_RDONLY - scm_c_define ("O_RDONLY", scm_from_long (O_RDONLY)); + scm_c_define ("O_RDONLY", scm_from_int (O_RDONLY)); #endif #ifdef O_WRONLY - scm_c_define ("O_WRONLY", scm_from_long (O_WRONLY)); + scm_c_define ("O_WRONLY", scm_from_int (O_WRONLY)); #endif #ifdef O_RDWR - scm_c_define ("O_RDWR", scm_from_long (O_RDWR)); + scm_c_define ("O_RDWR", scm_from_int (O_RDWR)); #endif #ifdef O_CREAT - scm_c_define ("O_CREAT", scm_from_long (O_CREAT)); + scm_c_define ("O_CREAT", scm_from_int (O_CREAT)); #endif #ifdef O_EXCL - scm_c_define ("O_EXCL", scm_from_long (O_EXCL)); + scm_c_define ("O_EXCL", scm_from_int (O_EXCL)); #endif #ifdef O_NOCTTY - scm_c_define ("O_NOCTTY", scm_from_long (O_NOCTTY)); + scm_c_define ("O_NOCTTY", scm_from_int (O_NOCTTY)); #endif #ifdef O_TRUNC - scm_c_define ("O_TRUNC", scm_from_long (O_TRUNC)); + scm_c_define ("O_TRUNC", scm_from_int (O_TRUNC)); #endif #ifdef O_APPEND - scm_c_define ("O_APPEND", scm_from_long (O_APPEND)); + scm_c_define ("O_APPEND", scm_from_int (O_APPEND)); #endif #ifdef O_NONBLOCK - scm_c_define ("O_NONBLOCK", scm_from_long (O_NONBLOCK)); + scm_c_define ("O_NONBLOCK", scm_from_int (O_NONBLOCK)); #endif #ifdef O_NDELAY - scm_c_define ("O_NDELAY", scm_from_long (O_NDELAY)); + scm_c_define ("O_NDELAY", scm_from_int (O_NDELAY)); #endif #ifdef O_SYNC - scm_c_define ("O_SYNC", scm_from_long (O_SYNC)); + scm_c_define ("O_SYNC", scm_from_int (O_SYNC)); #endif #ifdef O_LARGEFILE - scm_c_define ("O_LARGEFILE", scm_from_long (O_LARGEFILE)); + scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE)); #endif #ifdef F_DUPFD - scm_c_define ("F_DUPFD", scm_from_long (F_DUPFD)); + scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD)); #endif #ifdef F_GETFD - scm_c_define ("F_GETFD", scm_from_long (F_GETFD)); + scm_c_define ("F_GETFD", scm_from_int (F_GETFD)); #endif #ifdef F_SETFD - scm_c_define ("F_SETFD", scm_from_long (F_SETFD)); + scm_c_define ("F_SETFD", scm_from_int (F_SETFD)); #endif #ifdef F_GETFL - scm_c_define ("F_GETFL", scm_from_long (F_GETFL)); + scm_c_define ("F_GETFL", scm_from_int (F_GETFL)); #endif #ifdef F_SETFL - scm_c_define ("F_SETFL", scm_from_long (F_SETFL)); + scm_c_define ("F_SETFL", scm_from_int (F_SETFL)); #endif #ifdef F_GETOWN - scm_c_define ("F_GETOWN", scm_from_long (F_GETOWN)); + scm_c_define ("F_GETOWN", scm_from_int (F_GETOWN)); #endif #ifdef F_SETOWN - scm_c_define ("F_SETOWN", scm_from_long (F_SETOWN)); + scm_c_define ("F_SETOWN", scm_from_int (F_SETOWN)); #endif #ifdef FD_CLOEXEC - scm_c_define ("FD_CLOEXEC", scm_from_long (FD_CLOEXEC)); + scm_c_define ("FD_CLOEXEC", scm_from_int (FD_CLOEXEC)); #endif #include "libguile/filesys.x" diff --git a/libguile/gc.c b/libguile/gc.c index d8b27d2f5..3e8c02e1e 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -223,6 +223,7 @@ unsigned long scm_mtrigger; /* GC Statistics Keeping */ unsigned long scm_cells_allocated = 0; +unsigned long scm_last_cells_allocated = 0; unsigned long scm_mallocated = 0; unsigned long scm_gc_cells_collected; unsigned long scm_gc_cells_collected_1 = 0; /* previous GC yield */ @@ -256,8 +257,7 @@ 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. */ diff --git a/libguile/gsubr.c b/libguile/gsubr.c index c0bdd841e..356d771e8 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -24,6 +24,8 @@ #include "libguile/gsubr.h" #include "libguile/deprecation.h" + +#include "libguile/private-options.h" /* * gsubr.c diff --git a/libguile/i18n.c b/libguile/i18n.c index 76dd9a514..e23f79072 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2006 Free Software Foundation, Inc. +/* Copyright (C) 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 @@ -46,6 +46,7 @@ void *alloca (size_t); #include "libguile/dynwind.h" #include "libguile/validate.h" #include "libguile/values.h" +#include "libguile/threads.h" #include <locale.h> #include <string.h> /* `strcoll ()' */ @@ -53,11 +54,29 @@ void *alloca (size_t); #include <errno.h> #if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L) +/* The GNU thread-aware locale API is documented in ``Thread-Aware Locale + Model, a Proposal'', by Ulrich Drepper: + + http://people.redhat.com/drepper/tllocale.ps.gz + + It is now also implemented by Darwin: + + http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/newlocale.3.html + + The whole API is being standardized by the X/Open Group (as of Jan. 2007) + following Drepper's proposal. */ # define USE_GNU_LOCALE_API #endif -#ifndef USE_GNU_LOCALE_API -# include "libguile/posix.h" /* for `scm_i_locale_mutex' */ +#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H) +# include <xlocale.h> +#endif + +#include "libguile/posix.h" /* for `scm_i_locale_mutex' */ + +#if (defined HAVE_LANGINFO_H) && (defined HAVE_NL_TYPES_H) +# include <langinfo.h> +# include <nl_types.h> #endif #ifndef HAVE_SETLOCALE @@ -69,6 +88,9 @@ setlocale (int category, const char *name) } #endif +/* Helper stringification macro. */ +#define SCM_I18N_STRINGIFY(_name) # _name + /* Locale objects, string and character collation, and other locale-dependent @@ -78,18 +100,16 @@ setlocale (int category, const char *name) locale API on non-GNU systems. The emulation is a bit "brute-force": Whenever a `-locale<?' procedure is passed a locale object, then: - 1. The `scm_t_locale_mutex' is locked. + 1. The `scm_i_locale_mutex' is locked. 2. A series of `setlocale ()' call is performed to store the current - locale for each category in an `scm_t_locale_settings' object. + locale for each category in an `scm_t_locale' object. 3. A series of `setlocale ()' call is made to install each of the locale categories of each of the base locales of each locale object, recursively, starting from the last locale object of the chain. 4. The settings captured in step (2) are restored. - 5. The `scm_t_locale_mutex' is released. + 5. The `scm_i_locale_mutex' is released. - Hopefully, some smart standard will make that hack useless someday... - A similar API can be found in MzScheme starting from version 200: - http://download.plt-scheme.org/chronology/mzmr200alpha14.html . + Hopefully, the X/Open standard will eventually make this hack useless. Note: We don't wrap glibc's `uselocale ()' call because it sets the locale of the current _thread_ (unlike `setlocale ()') and doing so would require @@ -97,62 +117,65 @@ setlocale (int category, const char *name) re-installing this locale upon locale-dependent calls. */ +/* Return the category mask corresponding to CAT. */ +#define SCM_LOCALE_CATEGORY_MASK(_cat) LC_ ## _cat ## _MASK + + #ifndef USE_GNU_LOCALE_API -/* Provide the locale category masks as found in glibc (copied from - <locale.h> as found in glibc 2.3.6). This must be kept in sync with - `locale-categories.h'. */ +/* Provide the locale category masks as found in glibc. This must be kept in + sync with `locale-categories.h'. */ -# define LC_CTYPE_MASK (1 << LC_CTYPE) -# define LC_COLLATE_MASK (1 << LC_COLLATE) -# define LC_MESSAGES_MASK (1 << LC_MESSAGES) -# define LC_MONETARY_MASK (1 << LC_MONETARY) -# define LC_NUMERIC_MASK (1 << LC_NUMERIC) -# define LC_TIME_MASK (1 << LC_TIME) +# define LC_CTYPE_MASK 1 +# define LC_COLLATE_MASK 2 +# define LC_MESSAGES_MASK 4 +# define LC_MONETARY_MASK 8 +# define LC_NUMERIC_MASK 16 +# define LC_TIME_MASK 32 # ifdef LC_PAPER -# define LC_PAPER_MASK (1 << LC_PAPER) +# define LC_PAPER_MASK 64 # else # define LC_PAPER_MASK 0 # endif # ifdef LC_NAME -# define LC_NAME_MASK (1 << LC_NAME) +# define LC_NAME_MASK 128 # else # define LC_NAME_MASK 0 # endif # ifdef LC_ADDRESS -# define LC_ADDRESS_MASK (1 << LC_ADDRESS) +# define LC_ADDRESS_MASK 256 # else # define LC_ADDRESS_MASK 0 # endif # ifdef LC_TELEPHONE -# define LC_TELEPHONE_MASK (1 << LC_TELEPHONE) +# define LC_TELEPHONE_MASK 512 # else # define LC_TELEPHONE_MASK 0 # endif # ifdef LC_MEASUREMENT -# define LC_MEASUREMENT_MASK (1 << LC_MEASUREMENT) +# define LC_MEASUREMENT_MASK 1024 # else # define LC_MEASUREMENT_MASK 0 # endif # ifdef LC_IDENTIFICATION -# define LC_IDENTIFICATION_MASK (1 << LC_IDENTIFICATION) +# define LC_IDENTIFICATION_MASK 2048 # else # define LC_IDENTIFICATION_MASK 0 # endif -# define LC_ALL_MASK (LC_CTYPE_MASK \ - | LC_NUMERIC_MASK \ - | LC_TIME_MASK \ - | LC_COLLATE_MASK \ - | LC_MONETARY_MASK \ - | LC_MESSAGES_MASK \ - | LC_PAPER_MASK \ - | LC_NAME_MASK \ - | LC_ADDRESS_MASK \ - | LC_TELEPHONE_MASK \ - | LC_MEASUREMENT_MASK \ - | LC_IDENTIFICATION_MASK \ +# define LC_ALL_MASK (LC_CTYPE_MASK \ + | LC_NUMERIC_MASK \ + | LC_TIME_MASK \ + | LC_COLLATE_MASK \ + | LC_MONETARY_MASK \ + | LC_MESSAGES_MASK \ + | LC_PAPER_MASK \ + | LC_NAME_MASK \ + | LC_ADDRESS_MASK \ + | LC_TELEPHONE_MASK \ + | LC_MEASUREMENT_MASK \ + | LC_IDENTIFICATION_MASK \ ) /* Locale objects as returned by `make-locale' on non-GNU systems. */ @@ -163,12 +186,28 @@ typedef struct scm_locale int category_mask; } *scm_t_locale; -#else + +/* Free the resources used by LOCALE. */ +static inline void +scm_i_locale_free (scm_t_locale locale) +{ + free (locale->locale_name); + locale->locale_name = NULL; +} + +#else /* USE_GNU_LOCALE_API */ /* Alias for glibc's locale type. */ typedef locale_t scm_t_locale; -#endif +#define scm_i_locale_free freelocale + +#endif /* USE_GNU_LOCALE_API */ + + +/* A locale object denoting the global locale. */ +SCM_GLOBAL_VARIABLE (scm_global_locale, "%global-locale"); + /* Validate parameter ARG as a locale object and set C_LOCALE to the corresponding C locale object. */ @@ -199,16 +238,8 @@ SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale) { scm_t_locale c_locale; - c_locale = (scm_t_locale)SCM_SMOB_DATA (locale); - -#ifdef USE_GNU_LOCALE_API - freelocale ((locale_t)c_locale); -#else - c_locale->base_locale = SCM_UNDEFINED; - free (c_locale->locale_name); - - scm_gc_free (c_locale, sizeof (* c_locale), "locale"); -#endif + c_locale = (scm_t_locale) SCM_SMOB_DATA (locale); + scm_i_locale_free (c_locale); return 0; } @@ -217,76 +248,38 @@ SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale) static SCM smob_locale_mark (SCM locale) { - scm_t_locale c_locale; - - c_locale = (scm_t_locale)SCM_SMOB_DATA (locale); - return (c_locale->base_locale); -} -#endif - + register SCM dependency; -SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0, - (SCM category_mask, SCM locale_name, SCM base_locale), - "Return a reference to a data structure representing a set of " - "locale datasets. Unlike for the @var{category} parameter for " - "@code{setlocale}, the @var{category_mask} parameter here uses " - "a single bit for each category, made by OR'ing together " - "@code{LC_*_MASK} bits.") -#define FUNC_NAME s_scm_make_locale -{ - SCM locale = SCM_BOOL_F; - int c_category_mask; - char *c_locale_name; - scm_t_locale c_base_locale, c_locale; - - SCM_VALIDATE_INT_COPY (1, category_mask, c_category_mask); - SCM_VALIDATE_STRING (2, locale_name); - SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale); - - c_locale_name = scm_to_locale_string (locale_name); - -#ifdef USE_GNU_LOCALE_API - - c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale); + if (!scm_is_eq (locale, SCM_VARIABLE_REF (scm_global_locale))) + { + scm_t_locale c_locale; - if (!c_locale) - locale = SCM_BOOL_F; + c_locale = (scm_t_locale) SCM_SMOB_DATA (locale); + dependency = (c_locale->base_locale); + } else - SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); - - free (c_locale_name); - -#else - - c_locale = scm_gc_malloc (sizeof (* c_locale), "locale"); - c_locale->base_locale = base_locale; - - c_locale->category_mask = c_category_mask; - c_locale->locale_name = c_locale_name; - - SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); + dependency = SCM_BOOL_F; + return dependency; +} #endif - return locale; -} -#undef FUNC_NAME -SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0, - (SCM obj), - "Return true if @var{obj} is a locale object.") -#define FUNC_NAME s_scm_locale_p -{ - if (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj)) - return SCM_BOOL_T; +static void inline scm_locale_error (const char *, int) SCM_NORETURN; - return SCM_BOOL_F; +/* Throw an exception corresponding to error ERR. */ +static void inline +scm_locale_error (const char *func_name, int err) +{ + scm_syserror_msg (func_name, + "Failed to install locale", + SCM_EOL, err); } -#undef FUNC_NAME -#ifndef USE_GNU_LOCALE_API /* Emulate GNU's reentrant locale API. */ +/* Emulating GNU's reentrant locale API. */ +#ifndef USE_GNU_LOCALE_API /* Maximum number of chained locales (via `base_locale'). */ @@ -309,7 +302,7 @@ get_current_locale_settings (scm_t_locale_settings *settings) #define SCM_DEFINE_LOCALE_CATEGORY(_name) \ { \ SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \ - if (!locale_name) \ + if (locale_name == NULL) \ goto handle_error; \ \ settings-> _name = strdup (locale_name); \ @@ -323,7 +316,7 @@ get_current_locale_settings (scm_t_locale_settings *settings) return 0; handle_error: - return errno; + return EINVAL; handle_oom: return ENOMEM; @@ -346,7 +339,7 @@ restore_locale_settings (const scm_t_locale_settings *settings) return 0; handle_error: - return errno; + return EINVAL; } /* Free memory associated with SETTINGS. */ @@ -376,7 +369,7 @@ install_locale_categories (const char *locale_name, int category_mask) else { #define SCM_DEFINE_LOCALE_CATEGORY(_name) \ - if (category_mask & LC_ ## _name ## _MASK) \ + if (category_mask & SCM_LOCALE_CATEGORY_MASK (_name)) \ { \ SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \ if (result == NULL) \ @@ -389,7 +382,7 @@ install_locale_categories (const char *locale_name, int category_mask) return 0; handle_error: - return errno; + return EINVAL; } /* Install LOCALE, recursively installing its base locales first. On @@ -398,6 +391,7 @@ static int install_locale (scm_t_locale locale) { scm_t_locale stack[LOCALE_STACK_SIZE_MAX]; + int category_mask = 0; size_t stack_size = 0; int stack_offset = 0; const char *result = NULL; @@ -412,12 +406,16 @@ install_locale (scm_t_locale locale) stack[stack_size++] = locale; + /* Keep track of which categories have already been taken into + account. */ + category_mask |= locale->category_mask; + if (locale->base_locale != SCM_UNDEFINED) - locale = (scm_t_locale)SCM_SMOB_DATA (locale->base_locale); + locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale); else locale = NULL; } - while (locale != NULL); + while ((locale != NULL) && (category_mask != LC_ALL_MASK)); /* Install the C locale to start from a pristine state. */ SCM_SYSCALL (result = setlocale (LC_ALL, "C")); @@ -442,7 +440,7 @@ install_locale (scm_t_locale locale) return 0; handle_error: - return errno; + return EINVAL; } /* Leave the locked locale section. */ @@ -481,19 +479,6 @@ enter_locale_section (scm_t_locale locale, return err; } -/* Throw an exception corresponding to error ERR. */ -static void inline -scm_locale_error (const char *func_name, int err) -{ - SCM s_err; - - s_err = scm_from_int (err); - scm_error (scm_system_error_key, func_name, - "Failed to install locale", - scm_cons (scm_strerror (s_err), SCM_EOL), - scm_cons (s_err, SCM_EOL)); -} - /* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */ #define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \ do \ @@ -514,10 +499,248 @@ scm_locale_error (const char *func_name, int err) } \ while (0) +/* Convert the current locale settings into a locale SMOB. On success, zero + is returned and RESULT points to the new SMOB. Otherwise, an error is + returned. */ +static int +get_current_locale (SCM *result) +{ + int err = 0; + scm_t_locale c_locale; + const char *current_locale; + + c_locale = scm_gc_malloc (sizeof (* c_locale), "locale"); + + + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); + + c_locale->category_mask = LC_ALL_MASK; + c_locale->base_locale = SCM_UNDEFINED; + + current_locale = setlocale (LC_ALL, NULL); + if (current_locale != NULL) + { + c_locale->locale_name = strdup (current_locale); + if (c_locale->locale_name == NULL) + err = ENOMEM; + } + else + err = EINVAL; + + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + + if (err) + scm_gc_free (c_locale, sizeof (* c_locale), "locale"); + else + SCM_NEWSMOB (*result, scm_tc16_locale_smob_type, c_locale); + + return err; +} + + #endif /* !USE_GNU_LOCALE_API */ + + +/* `make-locale' can take either category lists or single categories (the + `LC_*' integer constants). */ +#define SCM_LIST_OR_INTEGER_P(arg) \ + (scm_is_integer (arg) || scm_is_true (scm_list_p (arg))) + + +/* Return the category mask corresponding to CATEGORY (an `LC_' integer + constant). */ +static inline int +category_to_category_mask (SCM category, + const char *func_name, int pos) +{ + int c_category; + int c_category_mask; + + c_category = scm_to_int (category); + +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + case LC_ ## _name: \ + c_category_mask = SCM_LOCALE_CATEGORY_MASK (_name); \ + break; + + switch (c_category) + { +#include "locale-categories.h" + + case LC_ALL: + c_category_mask = LC_ALL_MASK; + break; + + default: + scm_wrong_type_arg_msg (func_name, pos, category, + "locale category"); + } + +#undef SCM_DEFINE_LOCALE_CATEGORY + + return c_category_mask; +} + +/* Convert CATEGORIES, a list of locale categories or a single category (an + integer), into a category mask. */ +static int +category_list_to_category_mask (SCM categories, + const char *func_name, int pos) +{ + int c_category_mask = 0; + + if (scm_is_integer (categories)) + c_category_mask = category_to_category_mask (categories, + func_name, pos); + else + for (; !scm_is_null (categories); categories = SCM_CDR (categories)) + { + SCM category = SCM_CAR (categories); + + c_category_mask |= + category_to_category_mask (category, func_name, pos); + } + + return c_category_mask; +} + + +SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0, + (SCM category_list, SCM locale_name, SCM base_locale), + "Return a reference to a data structure representing a set of " + "locale datasets. @var{category_list} should be either a list " + "of locale categories or a single category as used with " + "@code{setlocale} (@pxref{Locales, @code{setlocale}}) and " + "@var{locale_name} should be the name of the locale considered " + "(e.g., @code{\"sl_SI\"}). Optionally, if @code{base_locale} is " + "passed, it should be a locale object denoting settings for " + "categories not listed in @var{category_list}.") +#define FUNC_NAME s_scm_make_locale +{ + SCM locale = SCM_BOOL_F; + int err = 0; + int c_category_mask; + char *c_locale_name; + scm_t_locale c_base_locale, c_locale; + + SCM_MAKE_VALIDATE (1, category_list, LIST_OR_INTEGER_P); + SCM_VALIDATE_STRING (2, locale_name); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale); + + c_category_mask = category_list_to_category_mask (category_list, + FUNC_NAME, 1); + c_locale_name = scm_to_locale_string (locale_name); + +#ifdef USE_GNU_LOCALE_API + + if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale))) + { + /* Fetch the current locale and turn in into a `locale_t'. Don't + duplicate the resulting `locale_t' because we want it to be consumed + by `newlocale ()'. */ + char *current_locale; + + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); + + current_locale = setlocale (LC_ALL, NULL); + c_base_locale = newlocale (LC_ALL_MASK, current_locale, NULL); + + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + + if (c_base_locale == (locale_t) 0) + scm_locale_error (FUNC_NAME, errno); + } + else if (c_base_locale != (locale_t) 0) + { + /* C_BASE_LOCALE is to be consumed by `newlocale ()' so it needs to be + duplicated before. */ + c_base_locale = duplocale (c_base_locale); + if (c_base_locale == (locale_t) 0) + { + err = errno; + goto fail; + } + } + + c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale); + + free (c_locale_name); + + if (c_locale == (locale_t) 0) + { + if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale))) + /* The base locale object was created lazily and must be freed. */ + freelocale (c_base_locale); + + scm_locale_error (FUNC_NAME, errno); + } + else + SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); + +#else + + c_locale = scm_gc_malloc (sizeof (* c_locale), "locale"); + + c_locale->category_mask = c_category_mask; + c_locale->locale_name = c_locale_name; + + if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale))) + { + /* Get the current locale settings and turn them into a locale + object. */ + err = get_current_locale (&base_locale); + if (err) + goto fail; + } + + c_locale->base_locale = base_locale; + + { + /* Try out the new locale and raise an exception if it doesn't work. */ + int err; + scm_t_locale_settings prev_locale; + + err = enter_locale_section (c_locale, &prev_locale); + leave_locale_section (&prev_locale); + + if (err) + goto fail; + else + SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); + } + +#endif + + return locale; + + fail: +#ifndef USE_GNU_LOCALE_API + scm_gc_free (c_locale, sizeof (* c_locale), "locale"); +#endif + free (c_locale_name); + scm_locale_error (FUNC_NAME, err); + + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0, + (SCM obj), + "Return true if @var{obj} is a locale object.") +#define FUNC_NAME s_scm_locale_p +{ + return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj)); +} +#undef FUNC_NAME + + -/* Locale-dependent string comparison. */ +/* Locale-dependent string comparison. + + A similar API can be found in MzScheme starting from version 200: + http://download.plt-scheme.org/chronology/mzmr200alpha14.html . */ + /* Compare null-terminated strings C_S1 and C_S2 according to LOCALE. Return an integer whose sign is the same as the difference between C_S1 and @@ -1124,33 +1347,388 @@ SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact", } #undef FUNC_NAME - -void -scm_init_i18n () +/* Language information, aka. `nl_langinfo ()'. */ + +/* FIXME: Issues related to `nl-langinfo'. + + 1. The `CODESET' value is not normalized. This is a secondary issue, but + still a practical issue. See + http://www.cl.cam.ac.uk/~mgk25/ucs/norm_charmap.c for codeset + normalization. + + 2. `nl_langinfo ()' is not available on Windows. + + 3. `nl_langinfo ()' may return strings encoded in a locale different from + the current one, thereby defeating `scm_from_locale_string ()'. + Example: support the current locale is "Latin-1" and one asks: + + (nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8")) + + The result will be a UTF-8 string. However, `scm_from_locale_string', + which expects a Latin-1 string, won't be able to make much sense of the + returned string. Thus, we'd need an `scm_from_string ()' variant where + the locale (or charset) is explicitly passed. */ + + +SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, + (SCM item, SCM locale), + "Return a string denoting locale information for @var{item} " + "in the current locale or that specified by @var{locale}. " + "The semantics and arguments are the same as those of the " + "X/Open @code{nl_langinfo} function (@pxref{The Elegant and " + "Fast Way, @code{nl_langinfo},, libc, The GNU C Library " + "Reference Manual}).") +#define FUNC_NAME s_scm_nl_langinfo +{ +#ifdef HAVE_NL_LANGINFO + SCM result; + nl_item c_item; + char *c_result; + scm_t_locale c_locale; + + SCM_VALIDATE_INT_COPY (2, item, c_item); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + /* Sadly, `nl_langinfo ()' returns a pointer to a static string. According + to SuS v2, that static string may be modified by subsequent calls to + `nl_langinfo ()' as well as by calls to `setlocale ()'. Thus, we must + acquire the locale mutex before doing invoking `nl_langinfo ()'. See + http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for + details. */ + + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); + if (c_locale != NULL) + { +#ifdef USE_GNU_LOCALE_API + c_result = nl_langinfo_l (c_item, c_locale); +#else + /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale + mutex is already taken. */ + int lsec_err; + scm_t_locale_settings lsec_prev_locale; + + lsec_err = get_current_locale_settings (&lsec_prev_locale); + if (lsec_err) + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + else + { + lsec_err = install_locale (c_locale); + if (lsec_err) + { + leave_locale_section (&lsec_prev_locale); + free_locale_settings (&lsec_prev_locale); + } + } + + if (lsec_err) + scm_locale_error (FUNC_NAME, lsec_err); + else + { + c_result = nl_langinfo (c_item); + + leave_locale_section (&lsec_prev_locale); + free_locale_settings (&lsec_prev_locale); + } +#endif + } + else + c_result = nl_langinfo (c_item); + + c_result = strdup (c_result); + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + + if (c_result == NULL) + result = SCM_BOOL_F; + else + { + char *p; + + switch (c_item) + { + case GROUPING: + case MON_GROUPING: + /* In this cases, the result is to be interpreted as a list of + numbers. If the last item is `CHARS_MAX', it has the special + meaning "no more grouping". */ + result = SCM_EOL; + for (p = c_result; (*p != '\0') && (*p != CHAR_MAX); p++) + result = scm_cons (SCM_I_MAKINUM ((int) *p), result); + + { + SCM last_pair = result; + + result = scm_reverse_x (result, SCM_EOL); + + if (*p != CHAR_MAX) + { + /* Cyclic grouping information. */ + if (last_pair != SCM_EOL) + SCM_SETCDR (last_pair, result); + } + } + + free (c_result); + break; + + case FRAC_DIGITS: + case INT_FRAC_DIGITS: + /* This is to be interpreted as a single integer. */ + if (*c_result == CHAR_MAX) + /* Unspecified. */ + result = SCM_BOOL_F; + else + result = SCM_I_MAKINUM (*c_result); + + free (c_result); + break; + + case P_CS_PRECEDES: + case N_CS_PRECEDES: + case INT_P_CS_PRECEDES: + case INT_N_CS_PRECEDES: + case P_SEP_BY_SPACE: + case N_SEP_BY_SPACE: + /* This is to be interpreted as a boolean. */ + result = scm_from_bool (*c_result); + + free (c_result); + break; + + case P_SIGN_POSN: + case N_SIGN_POSN: + case INT_P_SIGN_POSN: + case INT_N_SIGN_POSN: + /* See `(libc) Sign of Money Amount' for the interpretation of the + return value here. */ + switch (*c_result) + { + case 0: + result = scm_from_locale_symbol ("parenthesize"); + break; + + case 1: + result = scm_from_locale_symbol ("sign-before"); + break; + + case 2: + result = scm_from_locale_symbol ("sign-after"); + break; + + case 3: + result = scm_from_locale_symbol ("sign-before-currency-symbol"); + break; + + case 4: + result = scm_from_locale_symbol ("sign-after-currency-symbol"); + break; + + default: + result = scm_from_locale_symbol ("unspecified"); + } + break; + + default: + /* FIXME: `locale_string ()' is not appropriate here because of + encoding issues (see comment above). */ + result = scm_take_locale_string (c_result); + } + } + + return result; +#else + scm_syserror_msg (FUNC_NAME, "`nl-langinfo' not supported on your system", + SCM_EOL, ENOSYS); + + return SCM_BOOL_F; +#endif +} +#undef FUNC_NAME + +/* Define the `nl_item' constants. */ +static inline void +define_langinfo_items (void) { - scm_add_feature ("ice-9-i18n"); +#if (defined HAVE_NL_TYPES_H) && (defined HAVE_LANGINFO_H) + +#define DEFINE_NLITEM_CONSTANT(_item) \ + scm_c_define (# _item, scm_from_int (_item)) + + DEFINE_NLITEM_CONSTANT (CODESET); + + /* Abbreviated days of the week. */ + DEFINE_NLITEM_CONSTANT (ABDAY_1); + DEFINE_NLITEM_CONSTANT (ABDAY_2); + DEFINE_NLITEM_CONSTANT (ABDAY_3); + DEFINE_NLITEM_CONSTANT (ABDAY_4); + DEFINE_NLITEM_CONSTANT (ABDAY_5); + DEFINE_NLITEM_CONSTANT (ABDAY_6); + DEFINE_NLITEM_CONSTANT (ABDAY_7); + + /* Long-named days of the week. */ + DEFINE_NLITEM_CONSTANT (DAY_1); /* Sunday */ + DEFINE_NLITEM_CONSTANT (DAY_2); /* Monday */ + DEFINE_NLITEM_CONSTANT (DAY_3); /* Tuesday */ + DEFINE_NLITEM_CONSTANT (DAY_4); /* Wednesday */ + DEFINE_NLITEM_CONSTANT (DAY_5); /* Thursday */ + DEFINE_NLITEM_CONSTANT (DAY_6); /* Friday */ + DEFINE_NLITEM_CONSTANT (DAY_7); /* Saturday */ + + /* Abbreviated month names. */ + DEFINE_NLITEM_CONSTANT (ABMON_1); /* Jan */ + DEFINE_NLITEM_CONSTANT (ABMON_2); + DEFINE_NLITEM_CONSTANT (ABMON_3); + DEFINE_NLITEM_CONSTANT (ABMON_4); + DEFINE_NLITEM_CONSTANT (ABMON_5); + DEFINE_NLITEM_CONSTANT (ABMON_6); + DEFINE_NLITEM_CONSTANT (ABMON_7); + DEFINE_NLITEM_CONSTANT (ABMON_8); + DEFINE_NLITEM_CONSTANT (ABMON_9); + DEFINE_NLITEM_CONSTANT (ABMON_10); + DEFINE_NLITEM_CONSTANT (ABMON_11); + DEFINE_NLITEM_CONSTANT (ABMON_12); + + /* Long month names. */ + DEFINE_NLITEM_CONSTANT (MON_1); /* January */ + DEFINE_NLITEM_CONSTANT (MON_2); + DEFINE_NLITEM_CONSTANT (MON_3); + DEFINE_NLITEM_CONSTANT (MON_4); + DEFINE_NLITEM_CONSTANT (MON_5); + DEFINE_NLITEM_CONSTANT (MON_6); + DEFINE_NLITEM_CONSTANT (MON_7); + DEFINE_NLITEM_CONSTANT (MON_8); + DEFINE_NLITEM_CONSTANT (MON_9); + DEFINE_NLITEM_CONSTANT (MON_10); + DEFINE_NLITEM_CONSTANT (MON_11); + DEFINE_NLITEM_CONSTANT (MON_12); + + DEFINE_NLITEM_CONSTANT (AM_STR); /* Ante meridiem string. */ + DEFINE_NLITEM_CONSTANT (PM_STR); /* Post meridiem string. */ + + DEFINE_NLITEM_CONSTANT (D_T_FMT); /* Date and time format for strftime. */ + DEFINE_NLITEM_CONSTANT (D_FMT); /* Date format for strftime. */ + DEFINE_NLITEM_CONSTANT (T_FMT); /* Time format for strftime. */ + DEFINE_NLITEM_CONSTANT (T_FMT_AMPM);/* 12-hour time format for strftime. */ + + DEFINE_NLITEM_CONSTANT (ERA); /* Alternate era. */ + DEFINE_NLITEM_CONSTANT (ERA_D_FMT); /* Date in alternate era format. */ + DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT); /* Date and time in alternate era + format. */ + DEFINE_NLITEM_CONSTANT (ERA_T_FMT); /* Time in alternate era format. */ + + DEFINE_NLITEM_CONSTANT (ALT_DIGITS); /* Alternate symbols for digits. */ + DEFINE_NLITEM_CONSTANT (RADIXCHAR); + DEFINE_NLITEM_CONSTANT (THOUSEP); + +#ifdef YESEXPR + DEFINE_NLITEM_CONSTANT (YESEXPR); +#endif +#ifdef NOEXPR + DEFINE_NLITEM_CONSTANT (NOEXPR); +#endif -#define _SCM_STRINGIFY_LC(_name) # _name -#define SCM_STRINGIFY_LC(_name) _SCM_STRINGIFY_LC (_name) +#ifdef CRNCYSTR /* currency symbol */ + DEFINE_NLITEM_CONSTANT (CRNCYSTR); +#endif - /* Define all the relevant `_MASK' variables. */ -#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ - scm_c_define ("LC_" SCM_STRINGIFY_LC (_name) "_MASK", \ - SCM_I_MAKINUM (LC_ ## _name ## _MASK)); -#include "locale-categories.h" + /* GNU extensions. */ -#undef SCM_DEFINE_LOCALE_CATEGORY -#undef SCM_STRINGIFY_LC -#undef _SCM_STRINGIFY_LC +#ifdef ERA_YEAR + DEFINE_NLITEM_CONSTANT (ERA_YEAR); /* Year in alternate era format. */ +#endif - scm_c_define ("LC_ALL_MASK", SCM_I_MAKINUM (LC_ALL_MASK)); + /* LC_MONETARY category: formatting of monetary quantities. + These items each correspond to a member of `struct lconv', + defined in <locale.h>. */ +#ifdef INT_CURR_SYMBOL + DEFINE_NLITEM_CONSTANT (INT_CURR_SYMBOL); +#endif +#ifdef MON_DECIMAL_POINT + DEFINE_NLITEM_CONSTANT (MON_DECIMAL_POINT); +#endif +#ifdef MON_THOUSANDS_SEP + DEFINE_NLITEM_CONSTANT (MON_THOUSANDS_SEP); +#endif +#ifdef MON_GROUPING + DEFINE_NLITEM_CONSTANT (MON_GROUPING); +#endif +#ifdef POSITIVE_SIGN + DEFINE_NLITEM_CONSTANT (POSITIVE_SIGN); +#endif +#ifdef NEGATIVE_SIGN + DEFINE_NLITEM_CONSTANT (NEGATIVE_SIGN); +#endif +#ifdef GROUPING + DEFINE_NLITEM_CONSTANT (GROUPING); +#endif +#ifdef INT_FRAC_DIGITS + DEFINE_NLITEM_CONSTANT (INT_FRAC_DIGITS); +#endif +#ifdef FRAC_DIGITS + DEFINE_NLITEM_CONSTANT (FRAC_DIGITS); +#endif +#ifdef P_CS_PRECEDES + DEFINE_NLITEM_CONSTANT (P_CS_PRECEDES); +#endif +#ifdef P_SEP_BY_SPACE + DEFINE_NLITEM_CONSTANT (P_SEP_BY_SPACE); +#endif +#ifdef N_CS_PRECEDES + DEFINE_NLITEM_CONSTANT (N_CS_PRECEDES); +#endif +#ifdef N_SEP_BY_SPACE + DEFINE_NLITEM_CONSTANT (N_SEP_BY_SPACE); +#endif +#ifdef P_SIGN_POSN + DEFINE_NLITEM_CONSTANT (P_SIGN_POSN); +#endif +#ifdef N_SIGN_POSN + DEFINE_NLITEM_CONSTANT (N_SIGN_POSN); +#endif +#ifdef INT_P_CS_PRECEDES + DEFINE_NLITEM_CONSTANT (INT_P_CS_PRECEDES); +#endif +#ifdef INT_P_SEP_BY_SPACE + DEFINE_NLITEM_CONSTANT (INT_P_SEP_BY_SPACE); +#endif +#ifdef INT_N_CS_PRECEDES + DEFINE_NLITEM_CONSTANT (INT_N_CS_PRECEDES); +#endif +#ifdef INT_N_SEP_BY_SPACE + DEFINE_NLITEM_CONSTANT (INT_N_SEP_BY_SPACE); +#endif +#ifdef INT_P_SIGN_POSN + DEFINE_NLITEM_CONSTANT (INT_P_SIGN_POSN); +#endif +#ifdef INT_N_SIGN_POSN + DEFINE_NLITEM_CONSTANT (INT_N_SIGN_POSN); +#endif + +#undef DEFINE_NLITEM_CONSTANT + +#endif /* HAVE_NL_TYPES_H */ +} + + +void +scm_init_i18n () +{ + SCM global_locale_smob; + +#ifdef HAVE_NL_LANGINFO + scm_add_feature ("nl-langinfo"); + define_langinfo_items (); +#endif #include "libguile/i18n.x" #ifndef USE_GNU_LOCALE_API scm_set_smob_mark (scm_tc16_locale_smob_type, smob_locale_mark); #endif + + /* Initialize the global locale object with a special `locale' SMOB. */ + SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL); + SCM_VARIABLE_SET (scm_global_locale, global_locale_smob); } diff --git a/libguile/i18n.h b/libguile/i18n.h index 7d5d9baa9..17dc240d8 100644 --- a/libguile/i18n.h +++ b/libguile/i18n.h @@ -22,6 +22,7 @@ #include "libguile/__scm.h" +SCM_API SCM scm_global_locale; SCM_API SCM scm_make_locale (SCM category_mask, SCM locale_name, SCM base_locale); SCM_API SCM scm_locale_p (SCM obj); SCM_API SCM scm_string_locale_lt (SCM s1, SCM s2, SCM locale); @@ -40,6 +41,7 @@ SCM_API SCM scm_string_locale_upcase (SCM chr, SCM locale); SCM_API SCM scm_string_locale_downcase (SCM chr, SCM locale); SCM_API SCM scm_locale_string_to_integer (SCM str, SCM base, SCM locale); SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale); +SCM_API SCM scm_nl_langinfo (SCM item, SCM locale); SCM_API void scm_init_i18n (void); diff --git a/libguile/init.c b/libguile/init.c index 664aee63a..b65bc17cb 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -127,6 +127,7 @@ #include "libguile/deprecated.h" #include "libguile/init.h" +#include "libguile/private-options.h" #ifdef HAVE_STRING_H #include <string.h> diff --git a/libguile/macros.c b/libguile/macros.c index f46d0b434..1e2a12ef6 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -30,6 +30,8 @@ #include "libguile/validate.h" #include "libguile/macros.h" +#include "libguile/private-options.h" + scm_t_bits scm_tc16_macro; diff --git a/libguile/numbers.c b/libguile/numbers.c index 3be5314e0..a8c8996fa 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -452,28 +452,21 @@ scm_i_make_ratio (SCM numerator, SCM denominator) /* No, it's a proper fraction. */ - return scm_double_cell (scm_tc16_fraction, - SCM_UNPACK (numerator), - SCM_UNPACK (denominator), 0); + { + 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 -static void scm_i_fraction_reduce (SCM z) -{ - if (!(SCM_FRACTION_REDUCED (z))) - { - SCM divisor; - divisor = scm_gcd (SCM_FRACTION_NUMERATOR (z), SCM_FRACTION_DENOMINATOR (z)); - if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1)))) - { - /* is this safe? */ - SCM_FRACTION_SET_NUMERATOR (z, scm_divide (SCM_FRACTION_NUMERATOR (z), divisor)); - SCM_FRACTION_SET_DENOMINATOR (z, scm_divide (SCM_FRACTION_DENOMINATOR (z), divisor)); - } - SCM_FRACTION_REDUCED_SET (z); - } -} - double scm_i_fraction2double (SCM z) { @@ -2387,7 +2380,6 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, } else if (SCM_FRACTIONP (n)) { - scm_i_fraction_reduce (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))); @@ -2441,7 +2433,6 @@ int scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) { SCM str; - scm_i_fraction_reduce (sexp); 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); @@ -3109,8 +3100,6 @@ scm_complex_equalp (SCM x, SCM y) SCM scm_i_fraction_equalp (SCM x, SCM y) { - scm_i_fraction_reduce (x); - scm_i_fraction_reduce (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), @@ -4492,7 +4481,12 @@ scm_product (SCM x, SCM y) else if (SCM_REALP (x)) { if (SCM_I_INUMP (y)) - return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x)); + { + /* 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); @@ -4512,8 +4506,13 @@ scm_product (SCM x, SCM y) else if (SCM_COMPLEXP (x)) { if (SCM_I_INUMP (y)) - return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x), - SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x)); + { + /* 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)); @@ -5425,10 +5424,7 @@ scm_numerator (SCM z) else if (SCM_BIGP (z)) return z; else if (SCM_FRACTIONP (z)) - { - scm_i_fraction_reduce (z); - return SCM_FRACTION_NUMERATOR (z); - } + return SCM_FRACTION_NUMERATOR (z); else if (SCM_REALP (z)) return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z))); else @@ -5447,10 +5443,7 @@ scm_denominator (SCM z) else if (SCM_BIGP (z)) return SCM_I_MAKINUM (1); else if (SCM_FRACTIONP (z)) - { - scm_i_fraction_reduce (z); - return SCM_FRACTION_DENOMINATOR (z); - } + return SCM_FRACTION_DENOMINATOR (z); else if (SCM_REALP (z)) return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z))); else diff --git a/libguile/numbers.h b/libguile/numbers.h index 8448b7fd2..2c2fdcf07 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -157,14 +157,6 @@ #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)) -#define SCM_FRACTION_SET_NUMERATOR(x, v) (SCM_SET_CELL_OBJECT_1 ((x), (v))) -#define SCM_FRACTION_SET_DENOMINATOR(x, v) (SCM_SET_CELL_OBJECT_2 ((x), (v))) - - /* I think the left half word is free in the type, so I'll use bit 17 */ -#define SCM_FRACTION_REDUCED_BIT 0x10000 -#define SCM_FRACTION_REDUCED_SET(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) | SCM_FRACTION_REDUCED_BIT))) -#define SCM_FRACTION_REDUCED_CLEAR(x) (SCM_SET_CELL_TYPE((x), (SCM_CELL_TYPE (x) & ~SCM_FRACTION_REDUCED_BIT))) -#define SCM_FRACTION_REDUCED(x) (0x10000 & SCM_CELL_TYPE (x)) diff --git a/libguile/options.c b/libguile/options.c index 47cf60a91..ae75e1318 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -95,11 +95,11 @@ 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) +get_option_setting (const scm_t_option options[]) { unsigned int i; SCM ls = SCM_EOL; - for (i = 0; i != n; ++i) + for (i = 0; options[i].name; ++i) { switch (options[i].type) { @@ -123,12 +123,12 @@ get_option_setting (const scm_t_option options[], unsigned int n) /* 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) +get_documented_option_setting (const scm_t_option options[]) { SCM ans = SCM_EOL; unsigned int i; - for (i = 0; i != n; ++i) + for (i = 0; options[i].name; ++i) { SCM ls = scm_cons (scm_from_locale_string (options[i].doc), SCM_EOL); switch (options[i].type) @@ -149,21 +149,36 @@ get_documented_option_setting (const scm_t_option options[], unsigned int n) } +static int +options_length (scm_t_option options[]) +{ + unsigned int i = 0; + for (; options[i].name != NULL; ++i) + ; + + return i; +} + /* 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. */ + * the new setting will overwrite the old one. + * + * If DRY_RUN is set, don't change anything. This is useful for trying out an option + * before entering a critical section. + */ static void -change_option_setting (SCM args, scm_t_option options[], unsigned int n, const char *s) +change_option_setting (SCM args, scm_t_option options[], const char *s, + int dry_run) { unsigned int i; SCM locally_protected_args = args; - SCM malloc_obj = scm_malloc_obj (n * sizeof (scm_t_bits)); + SCM malloc_obj = scm_malloc_obj (options_length (options) * sizeof (scm_t_bits)); scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj); - for (i = 0; i != n; ++i) + for (i = 0; options[i].name; ++i) { if (options[i].type == SCM_OPTION_BOOLEAN) flags[i] = 0; @@ -176,7 +191,7 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c SCM name = SCM_CAR (args); int found = 0; - for (i = 0; i != n && !found; ++i) + for (i = 0; options[i].name && !found; ++i) { if (scm_is_eq (name, SCM_PACK (options[i].name))) { @@ -204,7 +219,10 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c args = SCM_CDR (args); } - for (i = 0; i != n; ++i) + if (dry_run) + return; + + for (i = 0; options[i].name; ++i) { if (options[i].type == SCM_OPTION_SCM) { @@ -223,32 +241,39 @@ change_option_setting (SCM args, scm_t_option options[], unsigned int n, const c SCM -scm_options (SCM args, scm_t_option options[], unsigned int n, const char *s) +scm_options (SCM args, scm_t_option options[], const char *s) +{ + return scm_options_try (args, options, s, 0); +} + +SCM +scm_options_try (SCM args, scm_t_option options[], const char *s, + int dry_run) { if (SCM_UNBNDP (args)) - return get_option_setting (options, n); + return get_option_setting (options); 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); + return get_documented_option_setting (options); 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); + old_setting = get_option_setting (options); + change_option_setting (args, options, s, dry_run); return old_setting; } } void -scm_init_opts (SCM (*func) (SCM), scm_t_option options[], unsigned int n) +scm_init_opts (SCM (*func) (SCM), scm_t_option options[]) { unsigned int i; - for (i = 0; i != n; ++i) + for (i = 0; options[i].name; ++i) { SCM name = scm_from_locale_symbol (options[i].name); options[i].name = (char *) SCM_UNPACK (name); diff --git a/libguile/options.h b/libguile/options.h index 650081cd2..5b9664958 100644 --- a/libguile/options.h +++ b/libguile/options.h @@ -40,8 +40,9 @@ typedef struct scm_t_option #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 SCM scm_options_try (SCM args, scm_t_option options[], const char *s, int dry_run); +SCM_API SCM scm_options (SCM, scm_t_option [], const char*); +SCM_API void scm_init_opts (SCM (*) (SCM), scm_t_option []); SCM_API void scm_init_options (void); #endif /* SCM_OPTIONS_H */ diff --git a/libguile/posix.c b/libguile/posix.c index 8129c6413..81539baf2 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -119,6 +119,10 @@ extern char ** environ; # define USE_GNU_LOCALE_API #endif +#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H) +# include <xlocale.h> +#endif + #if HAVE_CRYPT_H # include <crypt.h> #endif @@ -491,11 +495,25 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0, /* 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) + { + if (raise (scm_to_int (sig)) != 0) + { + err: + SCM_SYSERROR; + } + else + { + errno = ENOSYS; + goto err; + } + } #endif - SCM_SYSERROR; return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -1316,9 +1334,6 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, { int rv; char *c_str = scm_to_locale_string (str); -#ifdef __MINGW32__ - size_t len = strlen (c_str); -#endif if (strchr (c_str, '=') == NULL) { @@ -1333,6 +1348,7 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, /* On e.g. Win32 hosts putenv() called with 'name=' removes the environment variable 'name'. */ int e; + size_t len = strlen (c_str); char *ptr = scm_malloc (len + 2); strcpy (ptr, c_str); strcpy (ptr+len, "="); @@ -1352,26 +1368,29 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, by getenv. It's not enough just to modify the string we set, because MINGW putenv copies it. */ - 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; - } + { + 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. */ @@ -1384,12 +1403,11 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0, } #undef FUNC_NAME -#ifndef USE_GNU_LOCALE_API /* This mutex is used to serialize invocations of `setlocale ()' on non-GNU - systems (i.e., systems where a reentrant locale API is not available). - See `i18n.c' for details. */ -scm_i_pthread_mutex_t scm_i_locale_mutex; -#endif + systems (i.e., systems where a reentrant locale API is not available). It + is also acquired before calls to `nl_langinfo ()'. See `i18n.c' for + details. */ +scm_i_pthread_mutex_t scm_i_locale_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; #ifdef HAVE_SETLOCALE @@ -1406,6 +1424,7 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, "the locale will be set using environment variables.") #define FUNC_NAME s_scm_setlocale { + int c_category; char *clocale; char *rv; @@ -1421,13 +1440,11 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, scm_dynwind_free (clocale); } -#ifndef USE_GNU_LOCALE_API + c_category = scm_i_to_lc_category (category, 1); + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); -#endif - rv = setlocale (scm_i_to_lc_category (category, 1), clocale); -#ifndef USE_GNU_LOCALE_API + rv = setlocale (c_category, clocale); scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); -#endif if (rv == NULL) { @@ -1565,7 +1582,7 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, #define FUNC_NAME s_scm_crypt { SCM ret; - char *c_key, *c_salt; + char *c_key, *c_salt, *c_ret; scm_dynwind_begin (0); scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); @@ -1575,8 +1592,14 @@ SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0, c_salt = scm_to_locale_string (salt); scm_dynwind_free (c_salt); - ret = scm_from_locale_string (crypt (c_key, 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; } @@ -1965,10 +1988,6 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, void scm_init_posix () { -#ifndef USE_GNU_LOCALE_API - scm_i_pthread_mutex_init (&scm_i_locale_mutex, NULL); -#endif - scm_add_feature ("posix"); #ifdef HAVE_GETEUID scm_add_feature ("EIDs"); diff --git a/libguile/print.c b/libguile/print.c index 32507d2ab..3064fa1bd 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -43,6 +43,9 @@ #include "libguile/validate.h" #include "libguile/print.h" + +#include "libguile/private-options.h" + /* {Names of immediate symbols} @@ -83,7 +86,9 @@ scm_t_option scm_print_opts[] = { "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'." - } + }, + { 0 }, + }; SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0, @@ -96,7 +101,6 @@ SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0, { SCM ans = scm_options (setting, scm_print_opts, - SCM_N_PRINT_OPTIONS, FUNC_NAME); return ans; } @@ -940,12 +944,14 @@ scm_write (SCM obj, SCM 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; } @@ -961,12 +967,14 @@ scm_display (SCM obj, SCM 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; } @@ -1098,12 +1106,14 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0, 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 @@ -1173,7 +1183,7 @@ scm_init_print () { SCM vtable, layout, type; - scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); + scm_init_opts (scm_print_options, scm_print_opts); scm_print_options (scm_list_4 (scm_from_locale_symbol ("highlight-prefix"), scm_from_locale_string ("{"), diff --git a/libguile/print.h b/libguile/print.h index 7e59ba8b3..740aa281f 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -26,15 +26,6 @@ #include "libguile/options.h" -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. */ diff --git a/libguile/private-gc.h b/libguile/private-gc.h index c27196355..fe9b35505 100644 --- a/libguile/private-gc.h +++ b/libguile/private-gc.h @@ -1,7 +1,22 @@ /* - (c) FSF 2002. -*/ - + * private-gc.h - private declarations for garbage collection. + * + * Copyright (C) 2002, 03, 04, 05, 06, 07 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * 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 PRIVATE_GC #define PRIVATE_GC diff --git a/libguile/private-options.h b/libguile/private-options.h new file mode 100644 index 000000000..eeaf0c17b --- /dev/null +++ b/libguile/private-options.h @@ -0,0 +1,103 @@ +/* + * private-options.h - private declarations for option handling + * + * We put this in a private header, since layout of data structures + * is an implementation detail that we want to hide. + * + * 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 + */ + +#ifndef PRIVATE_OPTIONS +#define PRIVATE_OPTIONS + +/* + evaluator + */ +SCM_API scm_t_option scm_eval_opts[]; + +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_EVAL_STACK scm_eval_opts[0].val + +#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_MEMOIZE_P scm_evaluator_trap_table[7].val +#define SCM_MEMOIZE_HDLR (SCM_PACK (scm_evaluator_trap_table[8].val)) + +/* + debugging. + */ +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 + + +/* + printing +*/ +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 + + +/* + read + */ +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 + +#endif /* PRIVATE_OPTIONS */ diff --git a/libguile/read.c b/libguile/read.c index d75839589..de2e87bed 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -38,6 +38,8 @@ #include "libguile/srfi-4.h" #include "libguile/read.h" +#include "libguile/private-options.h" + @@ -52,14 +54,14 @@ scm_t_option scm_read_opts[] = { { 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 or 'prefix."} + "Style of keyword recognition: #f or 'prefix."}, #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."} + "Support `\\(' and `\\)' in strings."}, #endif + { 0, }, }; /* @@ -112,7 +114,6 @@ SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0, { SCM ans = scm_options (setting, scm_read_opts, - SCM_N_READ_OPTIONS, FUNC_NAME); if (SCM_COPY_SOURCE_P) SCM_RECORD_POSITIONS_P = 1; @@ -898,7 +899,9 @@ SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0, "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}.") + "returned will be the return value of @code{read}. \n" + "Passing @code{#f} for @var{proc} will remove a previous setting. \n" + ) #define FUNC_NAME s_scm_read_hash_extend { SCM this; @@ -977,7 +980,7 @@ 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); + scm_init_opts (scm_read_options, scm_read_opts); #include "libguile/read.x" } diff --git a/libguile/read.h b/libguile/read.h index 4bfa59eb0..9ff362603 100644 --- a/libguile/read.h +++ b/libguile/read.h @@ -45,19 +45,7 @@ #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 + diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index 9332f2661..f8677a1a3 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc. +/* 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 @@ -218,6 +218,17 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, "@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; @@ -245,7 +256,6 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, whole regexp, so add 1 to nmatches. */ nmatches = SCM_RGX(rx)->re_nsub + 1; - SCM_CRITICAL_SECTION_START; matches = scm_malloc (sizeof (regmatch_t) * nmatches); c_str = scm_to_locale_string (substr); status = regexec (SCM_RGX (rx), c_str, nmatches, matches, @@ -269,7 +279,6 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, scm_from_long (matches[i].rm_eo + offset))); } free (matches); - SCM_CRITICAL_SECTION_END; if (status != 0 && status != REG_NOMATCH) scm_error_scm (scm_regexp_error_key, @@ -287,14 +296,14 @@ scm_init_regex_posix () scm_set_smob_free (scm_tc16_regex, regex_free); /* Compilation flags. */ - scm_c_define ("regexp/basic", scm_from_long (REG_BASIC)); - scm_c_define ("regexp/extended", scm_from_long (REG_EXTENDED)); - scm_c_define ("regexp/icase", scm_from_long (REG_ICASE)); - scm_c_define ("regexp/newline", scm_from_long (REG_NEWLINE)); + 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_long (REG_NOTBOL)); - scm_c_define ("regexp/noteol", scm_from_long (REG_NOTEOL)); + 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" diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 3452f911c..9b1c96d42 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -22,6 +22,7 @@ # include <config.h> #endif +#include <fcntl.h> /* for mingw */ #include <signal.h> #include <stdio.h> #include <errno.h> @@ -36,6 +37,14 @@ #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 @@ -50,7 +59,7 @@ /* 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 kill(pid, sig) raise (sig) +#define pipe(fd) _pipe (fd, 256, O_BINARY) #endif @@ -106,6 +115,12 @@ close_1 (SCM proc, SCM arg) } #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]; @@ -149,12 +164,13 @@ read_without_guile (int fd, char *buf, size_t n) static SCM signal_delivery_thread (void *data) { - sigset_t all_sigs; 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) { @@ -616,7 +632,7 @@ SCM_DEFINE (scm_raise, "raise", 1, 0, 0, "@var{sig} is as described for the kill procedure.") #define FUNC_NAME s_scm_raise { - if (kill (getpid (), scm_to_int (sig)) != 0) + if (raise (scm_to_int (sig)) != 0) SCM_SYSERROR; return SCM_UNSPECIFIED; } diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 8b9348e85..e3691d4fb 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -38,7 +38,7 @@ /* {Source Properties} * * Properties of source list expressions. - * Five of these have special meaning and optimized storage: + * Five of these have special meaning: * * filename string The name of the source file. * copy list A copy of the list expression. @@ -56,8 +56,46 @@ 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) @@ -80,19 +118,45 @@ scm_c_source_property_breakpoint_p (SCM form) } +/* + * 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) { - register scm_t_srcprops *ptr; - - ptr = scm_gc_malloc (sizeof (*ptr), "srcprop"); - - ptr->pos = SRCPROPMAKPOS (line, col); - ptr->fname = filename; - ptr->copy = copy; - ptr->plist = plist; + if (!SCM_UNBNDP (filename)) + { + SCM old_plist = plist; - SCM_RETURN_NEWSMOB (scm_tc16_srcprops, ptr); + /* + 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); } @@ -102,8 +166,6 @@ scm_srcprops_to_plist (SCM obj) SCM plist = SRCPROPPLIST (obj); if (!SCM_UNBNDP (SRCPROPCOPY (obj))) plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist); - if (!SCM_UNBNDP (SRCPROPFNAME (obj))) - plist = scm_acons (scm_sym_filename, SRCPROPFNAME (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); @@ -168,7 +230,6 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, 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_filename, key)) p = SRCPROPFNAME (p); else if (scm_is_eq (scm_sym_copy, key)) p = SRCPROPCOPY (p); else { @@ -239,13 +300,6 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, scm_make_srcprops (0, scm_to_int (datum), SCM_UNDEFINED, SCM_UNDEFINED, p)); } - else if (scm_is_eq (scm_sym_filename, key)) - { - if (SRCPROPSP (p)) - SRCPROPFNAME (p) = datum; - else - SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p)); - } else if (scm_is_eq (scm_sym_copy, key)) { if (SRCPROPSP (p)) @@ -269,19 +323,19 @@ 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" } -void -scm_finish_srcprop () -{ - /* Nothing to do. */ -} /* Local Variables: diff --git a/libguile/srcprop.h b/libguile/srcprop.h index 0806a299e..87e5fde0f 100644 --- a/libguile/srcprop.h +++ b/libguile/srcprop.h @@ -49,40 +49,10 @@ do { \ /* {Source properties} */ - -SCM_API scm_t_bits scm_tc16_srcprops; - -typedef struct scm_t_srcprops -{ - unsigned long pos; - SCM fname; - SCM copy; - SCM plist; -} scm_t_srcprops; - - +#define SCM_PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace))) #define SCM_SOURCE_PROPERTY_FLAG_BREAK 1 -#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_t_srcprops *) SCM_SMOB_DATA (p))->pos -#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) -#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) -#define SRCPROPFNAME(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->fname -#define SRCPROPCOPY(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->copy -#define SRCPROPPLIST(p) ((scm_t_srcprops *) SCM_SMOB_DATA (p))->plist -#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) (SRCPROPPOS (p) = SRCPROPMAKPOS (l, c)) -#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p)) -#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c) - -#define PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace))) +SCM_API scm_t_bits scm_tc16_srcprops; SCM_API SCM scm_sym_filename; SCM_API SCM scm_sym_copy; diff --git a/libguile/stacks.c b/libguile/stacks.c index de85522ca..922c52231 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -32,6 +32,8 @@ #include "libguile/validate.h" #include "libguile/stacks.h" +#include "libguile/private-options.h" + /* {Frames and stacks} diff --git a/libguile/struct.c b/libguile/struct.c index 181b3d32c..e96a4912a 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -540,10 +540,15 @@ scm_i_struct_equalp (SCM s1, SCM s2) field1 = scm_struct_ref (s1, s_field_num); field2 = scm_struct_ref (s2, s_field_num); - if (scm_is_false (scm_equal_p (field1, field2))) - return SCM_BOOL_F; + /* 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 diff --git a/libguile/symbols.c b/libguile/symbols.c index e702fd3b4..ff75bef7d 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -40,6 +40,9 @@ #include "libguile/validate.h" #include "libguile/symbols.h" +#include "libguile/private-options.h" + + #ifdef HAVE_STRING_H #include <string.h> #endif diff --git a/libguile/threads.c b/libguile/threads.c index d15046bd2..c0a6cf110 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -131,9 +131,32 @@ dequeue (SCM q) 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 ((size_t)t->pthread, 10, port); + scm_uintprint (id, 10, port); scm_puts (" (", port); scm_uintprint ((scm_t_bits)t, 16, port); scm_puts (")>", port); @@ -563,9 +586,11 @@ scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent) } #if SCM_USE_PTHREAD_THREADS -/* pthread_getattr_np not available on MacOS X and Solaris 10. */ -#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP +#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 * @@ -598,7 +623,30 @@ get_thread_stack_base () } } -#endif /* HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP */ +#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 */ diff --git a/libguile/throw.c b/libguile/throw.c index 115bb0c03..02503c36a 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -37,6 +37,10 @@ #include "libguile/validate.h" #include "libguile/throw.h" #include "libguile/init.h" +#include "libguile/strings.h" + +#include "libguile/private-options.h" + /* the jump buffer data structure */ @@ -695,7 +699,31 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED) if (scm_i_critical_section_level) { + SCM s = args; + int i = 0; + + /* + We have much better routines for displaying Scheme, but we're + already inside a pernicious error, and it's unlikely that they + are available to us. We try to print something useful anyway, + so users don't need a debugger to find out what went wrong. + */ fprintf (stderr, "throw from within critical section.\n"); + if (scm_is_symbol (key)) + fprintf (stderr, "error key: %s\n", scm_i_symbol_chars (key)); + + + for (; scm_is_pair (s); s = scm_cdr (s), i++) + { + char const *str = NULL; + if (scm_is_string (scm_car (s))) + str = scm_i_string_chars (scm_car (s)); + else if (scm_is_symbol (scm_car (s))) + str = scm_i_symbol_chars (scm_car (s)); + + if (str != NULL) + fprintf (stderr, "argument %d: %s\n", i, str); + } abort (); } diff --git a/libguile/version.h.in b/libguile/version.h.in index 691898cd5..1d8f27750 100644 --- a/libguile/version.h.in +++ b/libguile/version.h.in @@ -30,12 +30,12 @@ #define SCM_MINOR_VERSION @-GUILE_MINOR_VERSION-@ #define SCM_MICRO_VERSION @-GUILE_MICRO_VERSION-@ -extern SCM scm_major_version (void); -extern SCM scm_minor_version (void); -extern SCM scm_micro_version (void); -extern SCM scm_effective_version (void); -extern SCM scm_version (void); -extern void scm_init_version (void); +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 */ diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 1d77d7747..fbc5e5d0f 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,34 @@ +2007-02-04 Ludovic Courtès <ludovic.courtes@laas.fr> + + * srfi/srfi-19.scm (priv:locale-abbr-weekday): Add one to the day + number before invoking `locale-day-short'. Failing to do so + resulted in days shifted by one in the result of `date->string', + or in the failure of `date->string' when the day is zero. + (priv:locale-long-weekday): Likewise. + +2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr> + + * srfi-19.scm: Use `(ice-9 i18n)'. + (priv:locale-abbr-weekday-vector, priv:locale-long-weekday-vector, + priv:locale-abbr-month-vector, priv:locale-long-month-vector): + Removed. + (priv:locale-number-separator, priv:locale-pm, priv:locale-am, + priv:locale-abbr-weekday, priv:locale-long-weekday, + priv:locale-abbr-month, priv:locale-long-month): Aliases for their + respective `(ice-9 i18n)' equivalent. + (priv:vector-find): Removed, replaced by... + (priv:date-reverse-lookup): New procedure. Updated callers. + (priv:locale-am/pm): Use `priv:locale-pm' and `priv:locale-am' as + procedures. + (priv:directives): Use `priv:locale-number-separator' as a + procedure. + +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!): @@ -282,7 +313,7 @@ 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. + return should be #t for an empty string. Reported by Andreas Vögele. 2004-07-10 Marius Vollmer <marius.vollmer@uni-dortmund.de> @@ -505,7 +536,7 @@ * 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". + make that "Köppe". 2002-04-24 Marius Vollmer <mvo@zagadka.ping.de> @@ -558,7 +589,7 @@ 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 + 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> @@ -977,7 +1008,7 @@ 2001-05-28 Michael Livshin <mlivshin@bigfoot.com> * srfi-19.scm: removed a stray open parenthesis. (thanks to - Matthias Köppe for the report). + Matthias Köppe for the report). 2001-05-23 Rob Browning <rlb@cs.utexas.edu> @@ -1233,3 +1264,7 @@ * Started guile-srfi-13 package. Files are copied from the guile-gdbm and slightly modified. + +;; Local Variables: +;; coding: utf-8 +;; End: diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index 896dd035f..1b71a16bd 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -41,7 +41,8 @@ (define-module (srfi srfi-19) :use-module (srfi srfi-6) :use-module (srfi srfi-8) - :use-module (srfi srfi-9)) + :use-module (srfi srfi-9) + :use-module (ice-9 i18n)) (begin-deprecated ;; Prevent `export' from re-exporting core bindings. This behaviour @@ -150,48 +151,9 @@ ;;-- 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") +(define priv:locale-number-separator locale-decimal-point) +(define priv:locale-pm locale-pm-string) +(define priv:locale-am locale-am-string) ;; See date->string (define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y") @@ -964,38 +926,33 @@ (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 n) (locale-day-short (+ 1 n))) +(define (priv:locale-long-weekday n) (locale-day (+ 1 n))) +(define priv:locale-abbr-month locale-month-short) +(define priv:locale-long-month locale-month) + +(define (priv:date-reverse-lookup needle haystack-ref haystack-len + same?) + ;; Lookup NEEDLE (a string) using HAYSTACK-REF (a one argument procedure + ;; that returns a string corresponding to the given index) by passing it + ;; indices lower than HAYSTACK-LEN. + (let loop ((index 1)) + (cond ((> index haystack-len) #f) + ((same? needle (haystack-ref index)) + index) + (else (loop (+ index 1)))))) (define (priv:locale-abbr-weekday->index string) - (priv:vector-find string priv:locale-abbr-weekday-vector string=?)) + (priv:date-reverse-lookup string priv:locale-abbr-weekday 7 string=?)) (define (priv:locale-long-weekday->index string) - (priv:vector-find string priv:locale-long-weekday-vector string=?)) + (priv:date-reverse-lookup string priv:locale-long-weekday 7 string=?)) (define (priv:locale-abbr-month->index string) - (priv:vector-find string priv:locale-abbr-month-vector string=?)) + (priv:date-reverse-lookup string priv:locale-abbr-month 12 string=?)) (define (priv:locale-long-month->index string) - (priv:vector-find string priv:locale-long-month-vector string=?)) + (priv:date-reverse-lookup string priv:locale-long-month 12 string=?)) ;; FIXME: mkoeppe: Put a symbolic time zone in the date structs. @@ -1003,10 +960,8 @@ (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)) + (if (> hr 11) (priv:locale-pm) (priv:locale-am))) (define (priv:tz-printer offset port) (cond @@ -1069,7 +1024,7 @@ (le (string-length ns))) (if (> le 2) (begin - (display priv:locale-number-separator port) + (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))) diff --git a/srfi/srfi-60.c b/srfi/srfi-60.c index 257b1387f..f631c6447 100644 --- a/srfi/srfi-60.c +++ b/srfi/srfi-60.c @@ -86,7 +86,7 @@ SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0, if (ii < SCM_LONG_BIT-1) { nn &= ~(1L << ii); /* zap bit at index */ - nn |= (bb << ii); /* insert desired bit */ + nn |= ((long) bb << ii); /* insert desired bit */ return scm_from_long (nn); } else diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index cd2141c0d..999c0c7d8 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,10 +1,72 @@ -2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr> +2007-01-31 Ludovic Courtès <ludovic.courtes@laas.fr> + + * tests/i18n.test: Use `(srfi srfi-1)'. + (exception:locale-error): New. + (locale objects): Test `make-locale' with both lists of `LC_*' + values and single `LC_*' values (instead of `LC_*_MASK' values). + [%global-locale]: New test. + (number parsing)[locale-string->inexact (French)]: New test. + (%c-locale, %english-days, every?): New top-level variables. + (nl-langinfo et al.): New test prefix. + + * tests/srfi-19.test: Install the C locale. + (SRFI date/time library)[string->date understands days and + months]: New test. + +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-24 Han-Wen Nienhuys <hanwen@lilypond.org> + + * tests/numbers.test ("equal?"): add case for reduction of + rational numbers. + +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-11-29 Ludovic Courtès <ludovic.courtes@laas.fr> +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 @@ -24,7 +86,7 @@ * tests/environments.test: Comment out all tests in this file. -2006-10-26 Ludovic Courtès <ludovic.courtes@laas.fr> +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'. diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 818a9b06d..111d470e1 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -1,5 +1,5 @@ ;;;; test-suite/lib.scm --- generic support for testing -;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc. +;;;; 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 @@ -30,6 +30,7 @@ exception:numerical-overflow exception:struct-set!-denied exception:miscellaneous-error + exception:string-contains-nul ;; Reporting passes and failures. run-test @@ -259,6 +260,11 @@ (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) diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index ec6481029..b95fdd0f9 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -29,7 +29,7 @@ BUILT_SOURCES = TESTS_ENVIRONMENT = "${top_builddir}/pre-inst-guile-env" -test_cflags := \ +test_cflags = \ -I$(top_srcdir)/test-suite/standalone \ -I$(top_srcdir) \ -I$(top_srcdir)/libguile-ltdl $(EXTRA_DEFS) $(GUILE_CFLAGS) @@ -38,7 +38,8 @@ AM_LDFLAGS = $(GUILE_CFLAGS) snarfcppopts = \ $(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS) -I$(top_srcdir) -%.x: %.c +SUFFIXES = .x +.c.x: ${top_builddir}/libguile/guile-snarf -o $@ $< $(snarfcppopts) CLEANFILES = *.x @@ -102,6 +103,9 @@ test_conversion_LDADD = ${top_builddir}/libguile/libguile.la check_PROGRAMS += test-conversion TESTS += test-conversion +# test-use-srfi +TESTS += test-use-srfi + all-local: cd ${srcdir} && chmod u+x ${check_SCRIPTS} diff --git a/test-suite/standalone/test-use-srfi b/test-suite/standalone/test-use-srfi new file mode 100755 index 000000000..309b3bda7 --- /dev/null +++ b/test-suite/standalone/test-use-srfi @@ -0,0 +1,67 @@ +#!/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 --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 --user-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 --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 --user-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 --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 --user-srfi=17 doesn't give SRFI-17 car" + exit 1 +fi diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 4adf0312f..519e2c0a1 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -1,5 +1,5 @@ ;;;; eval.test --- tests guile's evaluator -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 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 @@ -202,6 +202,33 @@ ))) ;;; +;;; 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 ;;; @@ -288,5 +315,20 @@ '(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 diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index fca99c768..78d7e54fb 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -1,6 +1,6 @@ ;;;; i18n.test --- Exercise the i18n API. ;;;; -;;;; Copyright (C) 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -19,25 +19,41 @@ (define-module (test-suite i18n) :use-module (ice-9 i18n) + :use-module (srfi srfi-1) :use-module (test-suite lib)) ;; Start from a pristine locale state. (setlocale LC_ALL "C") +(define exception:locale-error + (cons 'system-error "Failed to install locale")) + + (with-test-prefix "locale objects" (pass-if "make-locale (2 args)" - (not (not (make-locale LC_ALL_MASK "C")))) + (not (not (make-locale LC_ALL "C")))) + + (pass-if "make-locale (2 args, list)" + (not (not (make-locale (list LC_COLLATE LC_MESSAGES) "C")))) (pass-if "make-locale (3 args)" - (not (not (make-locale LC_COLLATE_MASK "C" - (make-locale LC_MESSAGES_MASK "C"))))) + (not (not (make-locale (list LC_COLLATE) "C" + (make-locale (list LC_MESSAGES) "C"))))) + + (pass-if-exception "make-locale with unknown locale" exception:locale-error + (make-locale LC_ALL "does-not-exist")) (pass-if "locale?" - (and (locale? (make-locale LC_ALL_MASK "C")) - (locale? (make-locale (logior LC_MESSAGES_MASK LC_NUMERIC_MASK) "C" - (make-locale LC_CTYPE_MASK "C")))))) + (and (locale? (make-locale (list LC_ALL) "C")) + (locale? (make-locale (list LC_MESSAGES LC_NUMERIC) "C" + (make-locale (list LC_CTYPE) "C"))))) + + (pass-if "%global-locale" + (and (locale? %global-locale)) + (locale? (make-locale (list LC_MONETARY) "C" + %global-locale)))) @@ -46,27 +62,30 @@ (pass-if "string-locale<?" (and (string-locale<? "hello" "world") (string-locale<? "hello" "world" - (make-locale LC_COLLATE_MASK "C")))) + (make-locale (list LC_COLLATE) "C")))) (pass-if "char-locale<?" (and (char-locale<? #\a #\b) - (char-locale<? #\a #\b (make-locale LC_COLLATE_MASK "C")))) + (char-locale<? #\a #\b (make-locale (list LC_COLLATE) "C")))) (pass-if "string-locale-ci=?" (and (string-locale-ci=? "Hello" "HELLO") (string-locale-ci=? "Hello" "HELLO" - (make-locale LC_COLLATE_MASK "C")))) + (make-locale (list LC_COLLATE) "C")))) (pass-if "string-locale-ci<?" (and (string-locale-ci<? "hello" "WORLD") (string-locale-ci<? "hello" "WORLD" - (make-locale LC_COLLATE_MASK "C"))))) + (make-locale (list LC_COLLATE) "C"))))) +(define %french-locale-name + "fr_FR.ISO-8859-1") + (define %french-locale (false-if-exception - (make-locale (logior LC_CTYPE_MASK LC_COLLATE_MASK) - "fr_FR.ISO-8859-1"))) + (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME) + %french-locale-name))) (define (under-french-locale-or-unresolved thunk) ;; On non-GNU systems, an exception may be raised only when the locale is @@ -112,11 +131,11 @@ (pass-if "char-locale-downcase" (and (eq? #\a (char-locale-downcase #\A)) - (eq? #\a (char-locale-downcase #\A (make-locale LC_ALL_MASK "C"))))) + (eq? #\a (char-locale-downcase #\A (make-locale LC_ALL "C"))))) (pass-if "char-locale-upcase" (and (eq? #\Z (char-locale-upcase #\z)) - (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL_MASK "C")))))) + (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL "C")))))) (with-test-prefix "number parsing" @@ -131,10 +150,98 @@ (call-with-values (lambda () (locale-string->inexact "123.456" - (make-locale LC_NUMERIC_MASK "C"))) + (make-locale (list LC_NUMERIC) "C"))) (lambda (result char-count) (and (equal? result 123.456) - (equal? char-count 7)))))) + (equal? char-count 7))))) + + (pass-if "locale-string->inexact (French)" + (under-french-locale-or-unresolved + (lambda () + (call-with-values + (lambda () + (locale-string->inexact "123,456" %french-locale)) + (lambda (result char-count) + (and (equal? result 123.456) + (equal? char-count 7)))))))) + + +;;; +;;; `nl-langinfo' +;;; + +(setlocale LC_ALL "C") +(define %c-locale (make-locale LC_ALL "C")) + +(define %english-days + '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) + +(define (every? . args) + (not (not (apply every args)))) + + +(with-test-prefix "nl-langinfo et al." + + (pass-if "locale-day (1 arg)" + (every? equal? + %english-days + (map locale-day (map 1+ (iota 7))))) + + (pass-if "locale-day (2 args)" + (every? equal? + %english-days + (map (lambda (day) + (locale-day day %c-locale)) + (map 1+ (iota 7))))) + + (pass-if "locale-day (2 args, using `%global-locale')" + (every? equal? + %english-days + (map (lambda (day) + (locale-day day %global-locale)) + (map 1+ (iota 7))))) + + (pass-if "locale-day (French)" + (under-french-locale-or-unresolved + (lambda () + (let ((result (locale-day 3 %french-locale))) + (and (string? result) + (string-ci=? result "mardi")))))) + + (pass-if "locale-day (French, using `%global-locale')" + ;; Make sure `%global-locale' captures the current locale settings as + ;; installed using `setlocale'. + (under-french-locale-or-unresolved + (lambda () + (dynamic-wind + (lambda () + (setlocale LC_TIME %french-locale-name)) + (lambda () + (let* ((fr (make-locale (list LC_MONETARY) "C" %global-locale)) + (result (locale-day 3 fr))) + (setlocale LC_ALL "C") + (and (string? result) + (string-ci=? result "mardi")))) + (lambda () + (setlocale LC_ALL "C")))))) + + (pass-if "default locale" + ;; Make sure the default locale does not capture the current locale + ;; settings as installed using `setlocale'. The default locale should be + ;; "C". + (under-french-locale-or-unresolved + (lambda () + (dynamic-wind + (lambda () + (setlocale LC_ALL %french-locale-name)) + (lambda () + (let* ((locale (make-locale (list LC_MONETARY) "C")) + (result (locale-day 3 locale))) + (setlocale LC_ALL "C") + (and (string? result) + (string-ci=? result "Tuesday")))) + (lambda () + (setlocale LC_ALL "C"))))))) ;;; Local Variables: diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 78d130a2b..b28b4ef97 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -2243,19 +2243,17 @@ (with-test-prefix "big / real" (pass-if (nan? (max big*5 +nan.0))) - (pass-if (= big*5 (max big*5 -inf.0))) - (pass-if (= +inf.0 (max big*5 +inf.0))) - (pass-if (= 1.0 (max (- big*5) 1.0))) - (pass-if (inexact? (max big*5 1.0))) - (pass-if (= (exact->inexact big*5) (max big*5 1.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 (= +inf.0 (max +inf.0 big*5))) - (pass-if (= big*5 (max -inf.0 big*5))) - (pass-if (= 1.0 (max 1.0 (- big*5)))) - (pass-if (inexact? (max 1.0 big*5))) - (pass-if (= (exact->inexact big*5) (max 1.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))) @@ -2370,19 +2368,17 @@ (with-test-prefix "big / real" (pass-if (nan? (min big*5 +nan.0))) - (pass-if (= big*5 (min big*5 +inf.0))) - (pass-if (= -inf.0 (min big*5 -inf.0))) - (pass-if (= 1.0 (min big*5 1.0))) - (pass-if (inexact? (min (- big*5) 1.0))) - (pass-if (= (exact->inexact (- big*5)) (min (- big*5) 1.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 (= big*5 (min +inf.0 big*5))) - (pass-if (= -inf.0 (min -inf.0 big*5))) - (pass-if (= 1.0 (min 1.0 big*5))) - (pass-if (inexact? (min 1.0 (- big*5)))) - (pass-if (= (exact->inexact (- big*5)) (min 1.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))) @@ -2463,10 +2459,52 @@ (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))))) + (* 1+1i big)))) + + (with-test-prefix "frac * inum" + + (pass-if "2/3 * 0 = 0" + (eqv? 0 (* 2/3 0))))) ;;; ;;; / @@ -3180,3 +3218,15 @@ (pass-if "-100i swings back to 45deg down" (eqv-loosely? +7.071-7.071i (sqrt -100.0i)))) + +;; +;; equal? +;; + + +(with-test-prefix "equal?" + (pass-if + + ;; lazy reduction bit for rationals should not affect equal? + (equal? 1/2 ((lambda (x) (denominator x) x) 1/2)))) + diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test index 7e7914534..3050af39b 100644 --- a/test-suite/tests/regexp.test +++ b/test-suite/tests/regexp.test @@ -1,7 +1,7 @@ ;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 ;;;; -;;;; Copyright (C) 1999, 2004, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 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 @@ -71,6 +71,38 @@ (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)))) + +;;; ;;; regexp-quote ;;; diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test index 806b420a6..0a0b42541 100644 --- a/test-suite/tests/srfi-17.test +++ b/test-suite/tests/srfi-17.test @@ -32,6 +32,13 @@ (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) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 126198afa..33e667cfc 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -27,6 +27,9 @@ :use-module (srfi srfi-19) :use-module (ice-9 format)) +;; Make sure we use the default locale. +(setlocale LC_ALL "C") + (define (with-tz* tz thunk) "Temporarily set the TZ environment variable to the passed string value and call THUNK." @@ -142,6 +145,19 @@ incomplete numerical tower implementation.)" (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)))) + (pass-if "string->date understands days and months" + (time=? (let ((d (string->date "Saturday, December 9, 2006" + "~A, ~B ~d, ~Y"))) + (date->time-utc (make-date (date-nanosecond d) + (date-second d) + (date-minute d) + (date-hour d) + (date-day d) + (date-month d) + (date-year d) + 0))) + (date->time-utc + (make-date 0 0 0 0 9 12 2006 0)))) ;; check time comparison procedures (let* ((time1 (make-time time-monotonic 0 0)) (time2 (make-time time-monotonic 0 0)) diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test index 050eb4224..5df4665a3 100644 --- a/test-suite/tests/structs.test +++ b/test-suite/tests/structs.test @@ -1,7 +1,7 @@ ;;;; structs.test --- Test suite for Guile's structures. -*- Scheme -*- ;;;; Ludovic Courtès <ludovic.courtes@laas.fr>, 2006-06-12. ;;;; -;;;; Copyright (C) 2006 Free Software Foundation, Inc. +;;;; 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 @@ -18,7 +18,8 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (test-suite lib)) +(define-module (test-suite test-structs) + :use-module (test-suite lib)) @@ -80,15 +81,27 @@ (pass-if "struct-set!" (let ((ball (make-ball green "Bob"))) (set-owner! ball "Bill") - (string=? (owner ball) "Bill"))) + (string=? (owner ball) "Bill")))) - (pass-if "equal?" + +(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")))) + (second (make-ball red (string-copy "Bob")))) (equal? first second))) (pass-if "not-equal?" - (not (or (equal? (make-ball red "Bob") (make-ball green "Bill")) + (not (or (equal? (make-ball red "Bob") (make-ball green "Bob")) (equal? (make-ball red "Bob") (make-ball red "Bill")))))) +;;; Local Variables: +;;; coding: latin-1 +;;; End: |