diff options
author | Michael Gran <spk121@yahoo.com> | 2021-03-06 08:30:23 -0800 |
---|---|---|
committer | Michael Gran <spk121@yahoo.com> | 2021-03-06 08:30:23 -0800 |
commit | 60fc69f6d5ee480a9c1bfab0eb7005dd6428414a (patch) | |
tree | 234ca67330b6f20669eca76abb2eb06d0806fe8a | |
parent | 99c42c5277d039e186f1570f7c59d7b9244f641f (diff) | |
parent | 1114122fbb13e843276a479f0966087e9d52e1f7 (diff) | |
download | guile-60fc69f6d5ee480a9c1bfab0eb7005dd6428414a.tar.gz |
Merge branch 'master' of git.savannah.gnu.org:/srv/git/guile into mingw-guile-3.0
58 files changed, 8986 insertions, 3084 deletions
@@ -18,35 +18,7 @@ explain how users should proceed for getting the programs to use the available translations. They tell how people wanting to contribute and work on translations can contact the appropriate team. - When reporting bugs in the `intl/' directory or bugs which may be -related to internationalization, you should tell about the version of -`gettext' which is used. The information can be found in the -`intl/VERSION' file, in internationalized packages. - -1.1 Quick configuration advice -============================== - -If you want to exploit the full power of internationalization, you -should configure it using - - ./configure --with-included-gettext - -to force usage of internationalizing routines provided within this -package, despite the existence of internationalizing capabilities in the -operating system where this package is being installed. So far, only -the `gettext' implementation in the GNU C library version 2 provides as -many features (such as locale alias, message inheritance, automatic -charset conversion or plural form handling) as the implementation here. -It is also not possible to offer this additional functionality on top -of a `catgets' implementation. Future versions of GNU `gettext' will -very likely convey even more functionality. So it might be a good idea -to change to GNU `gettext' as soon as possible. - - So you need _not_ provide this option if you are using GNU libc 2 or -you have installed a recent copy of the GNU gettext package with the -included `libintl'. - -1.2 INSTALL Matters +1.1 INSTALL Matters =================== Some packages are "localizable" when properly installed; the programs @@ -56,36 +28,19 @@ internationalization, predating GNU `gettext'. By default, this package will be installed to allow translation of messages. It will automatically detect whether the system already -provides the GNU `gettext' functions. If not, the included GNU -`gettext' library will be used. This library is wholly contained -within this package, usually in the `intl/' subdirectory, so prior -installation of the GNU `gettext' package is _not_ required. -Installers may use special options at configuration time for changing -the default behaviour. The commands: +provides the GNU `gettext' functions. Installers may use special +options at configuration time for changing the default behaviour. The +command: - ./configure --with-included-gettext ./configure --disable-nls -will, respectively, bypass any pre-existing `gettext' to use the -internationalizing routines provided within this package, or else, -_totally_ disable translation of messages. +will _totally_ disable translation of messages. When you already have GNU `gettext' installed on your system and run configure without an option for your new package, `configure' will -probably detect the previously built and installed `libintl.a' file and -will decide to use this. This might not be desirable. You should use -the more recent version of the GNU `gettext' library. I.e. if the file -`intl/VERSION' shows that the library which comes with this package is -more recent, you should use - - ./configure --with-included-gettext - -to prevent auto-detection. - - The configuration process will not test for the `catgets' function -and therefore it will not be used. The reason is that even an -emulation of `gettext' on top of `catgets' could not provide all the -extensions of the GNU `gettext' library. +probably detect the previously built and installed `libintl' library +and will decide to use it. If not, you may have to to use the +`--with-libintl-prefix' option to tell `configure' where to look for it. Internationalized packages usually have many `po/LL.po' files, where LL gives an ISO 639 two-letter code identifying the language. Unless @@ -96,13 +51,16 @@ may be set, prior to configuration, to limit the installed set. `LINGUAS' should then contain a space separated list of two-letter codes, stating which languages are allowed. -1.3 Using This Package +1.2 Using This Package ====================== As a user, if your language has been installed for this package, you only have to set the `LANG' environment variable to the appropriate -`LL_CC' combination. Here `LL' is an ISO 639 two-letter language code, -and `CC' is an ISO 3166 two-letter country code. For example, let's +`LL_CC' combination. If you happen to have the `LC_ALL' or some other +`LC_xxx' environment variables set, you should unset them before +setting `LANG', otherwise the setting of `LANG' will not have the +desired effect. Here `LL' is an ISO 639 two-letter language code, and +`CC' is an ISO 3166 two-letter country code. For example, let's suppose that you speak German and live in Germany. At the shell prompt, merely execute `setenv LANG de_DE' (in `csh'), `export LANG; LANG=de_DE' (in `sh') or `export LANG=de_DE' (in `bash'). @@ -145,7 +103,7 @@ to denote the language's main dialect. For example, `de' is equivalent to `de_DE' (German as spoken in Germany), and `pt' to `pt_PT' (Portuguese as spoken in Portugal) in this context. -1.4 Translating Teams +1.3 Translating Teams ===================== For the Free Translation Project to be a success, we need interested @@ -153,8 +111,7 @@ people who like their own language and write it well, and who are also able to synergize with other translators speaking the same language. Each translation team has its own mailing list. The up-to-date list of teams can be found at the Free Translation Project's homepage, -`http://www.iro.umontreal.ca/contrib/po/HTML/', in the "National teams" -area. +`http://translationproject.org/', in the "Teams" area. If you'd like to volunteer to _work_ at translating messages, you should become a member of the translating team for your own language. @@ -168,901 +125,1125 @@ message to `sv-request@li.org', having this message body: _actively_ in translations, or at solving translational difficulties, rather than merely lurking around. If your team does not exist yet and you want to start one, or if you are unsure about what to do or how to -get started, please write to `translation@iro.umontreal.ca' to reach the -coordinator for all translator teams. +get started, please write to `coordinator@translationproject.org' to +reach the coordinator for all translator teams. The English team is special. It works at improving and uniformizing the terminology in use. Proven linguistic skills are praised more than programming skills, here. -1.5 Available Packages +1.4 Available Packages ====================== Languages are not equally supported in all packages. The following -matrix shows the current state of internationalization, as of October -2006. The matrix shows, in regard of each package, for which languages +matrix shows the current state of internationalization, as of June +2010. The matrix shows, in regard of each package, for which languages PO files have been submitted to translation coordination, with a translation percentage of at least 50%. - Ready PO files af am ar az be bg bs ca cs cy da de el en en_GB eo - +----------------------------------------------------+ - GNUnet | [] | - a2ps | [] [] [] [] [] | - aegis | () | - ant-phone | () | - anubis | [] | - ap-utils | | - aspell | [] [] [] [] [] | - bash | [] [] [] | - batchelor | [] | - bfd | | - bibshelf | [] | - binutils | [] | - bison | [] [] | - bison-runtime | | - bluez-pin | [] [] [] [] [] | - cflow | [] | - clisp | [] [] | - console-tools | [] [] | - coreutils | [] [] [] | - cpio | | - cpplib | [] [] [] | - cryptonit | [] | - darkstat | [] () [] | - dialog | [] [] [] [] [] [] | - diffutils | [] [] [] [] [] [] | - doodle | [] | - e2fsprogs | [] [] | - enscript | [] [] [] [] | - error | [] [] [] [] | - fetchmail | [] [] () [] | - fileutils | [] [] | - findutils | [] [] [] | - flex | [] [] [] | - fslint | [] | - gas | | - gawk | [] [] [] | - gbiff | [] | - gcal | [] | - gcc | [] | - gettext-examples | [] [] [] [] [] | - gettext-runtime | [] [] [] [] [] | - gettext-tools | [] [] | - gimp-print | [] [] [] [] | - gip | [] | - gliv | [] | - glunarclock | [] | - gmult | [] [] | - gnubiff | () | - gnucash | () () [] | - gnucash-glossary | [] () | - gnuedu | | - gnulib | [] [] [] [] [] [] | - gnunet-gtk | | - gnutls | | - gpe-aerial | [] [] | - gpe-beam | [] [] | - gpe-calendar | | - gpe-clock | [] [] | - gpe-conf | [] [] | - gpe-contacts | | - gpe-edit | [] | - gpe-filemanager | | - gpe-go | [] | - gpe-login | [] [] | - gpe-ownerinfo | [] [] | - gpe-package | | - gpe-sketchbook | [] [] | - gpe-su | [] [] | - gpe-taskmanager | [] [] | - gpe-timesheet | [] | - gpe-today | [] [] | - gpe-todo | | - gphoto2 | [] [] [] [] | - gprof | [] [] | - gpsdrive | () () | - gramadoir | [] [] | - grep | [] [] [] [] [] [] | - gretl | | - gsasl | | - gss | | - gst-plugins | [] [] [] [] | - gst-plugins-base | [] [] [] | - gst-plugins-good | [] [] [] [] [] [] [] | - gstreamer | [] [] [] [] [] [] [] | - gtick | () | - gtkam | [] [] [] | - gtkorphan | [] [] | - gtkspell | [] [] [] [] | - gutenprint | [] | - hello | [] [] [] [] [] | - id-utils | [] [] | - impost | | - indent | [] [] [] | - iso_3166 | [] [] | - iso_3166_2 | | - iso_4217 | [] | - iso_639 | [] [] | - jpilot | [] | - jtag | | - jwhois | | - kbd | [] [] [] [] | - keytouch | | - keytouch-editor | | - keytouch-keyboa... | | - latrine | () | - ld | [] | - leafpad | [] [] [] [] [] | - libc | [] [] [] [] [] | - libexif | [] | - libextractor | [] | - libgpewidget | [] [] [] | - libgpg-error | [] | - libgphoto2 | [] [] | - libgphoto2_port | [] [] | - libgsasl | | - libiconv | [] [] | - libidn | [] [] | - lifelines | [] () | - lilypond | [] | - lingoteach | | - lynx | [] [] [] [] | - m4 | [] [] [] [] | - mailutils | [] | - make | [] [] | - man-db | [] () [] [] | - minicom | [] [] [] | - mysecretdiary | [] [] | - nano | [] [] [] | - nano_1_0 | [] () [] [] | - opcodes | [] | - parted | | - pilot-qof | [] | - psmisc | [] | - pwdutils | | - python | | - qof | | - radius | [] | - recode | [] [] [] [] [] [] | - rpm | [] [] | - screem | | - scrollkeeper | [] [] [] [] [] [] [] [] | - sed | [] [] [] | - sh-utils | [] [] | - shared-mime-info | [] [] [] [] | - sharutils | [] [] [] [] [] [] | - shishi | | - silky | | - skencil | [] () | - sketch | [] () | - solfege | | - soundtracker | [] [] | - sp | [] | - stardict | [] | - system-tools-ba... | [] [] [] [] [] [] [] [] [] | - tar | [] | - texinfo | [] [] [] | - textutils | [] [] [] | - tin | () () | - tp-robot | [] | - tuxpaint | [] [] [] [] [] | - unicode-han-tra... | | - unicode-transla... | | - util-linux | [] [] [] [] | - vorbis-tools | [] [] [] [] | - wastesedge | () | - wdiff | [] [] [] [] | - wget | [] [] | - xchat | [] [] [] [] [] [] | - xkeyboard-config | | - xpad | [] [] | - +----------------------------------------------------+ - af am ar az be bg bs ca cs cy da de el en en_GB eo - 10 0 1 2 9 22 1 42 41 2 60 95 16 1 17 16 - - es et eu fa fi fr ga gl gu he hi hr hu id is it + Ready PO files af am an ar as ast az be be@latin bg bn_IN bs ca +--------------------------------------------------+ - GNUnet | | - a2ps | [] [] [] () | + 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 | [] [] [] [] [] [] [] [] | + ant-phone | | + anubis | | + aspell | [] [] | + bash | | + bfd | | + bibshelf | [] | + binutils | | + bison | | + bison-runtime | [] | + bluez-pin | [] [] | + bombono-dvd | | + buzztard | | + cflow | | + clisp | | + coreutils | [] [] | + cpio | | + cppi | | + cpplib | [] | + cryptsetup | | + dfarc | | + dialog | [] [] | + dico | | + diffutils | [] | + dink | | + doodle | | + e2fsprogs | [] | + enscript | [] | + exif | | + fetchmail | [] | + findutils | [] | + flex | [] | + freedink | | + gas | | + gawk | [] [] | + gcal | [] | + gcc | | + gettext-examples | [] [] [] [] | + gettext-runtime | [] [] | + gettext-tools | [] [] | + gip | [] | + gjay | | + gliv | [] | + glunarclock | [] [] | + gnubiff | | + gnucash | [] | + gnuedu | | + gnulib | | + gnunet | | gnunet-gtk | | gnutls | | - gpe-aerial | [] [] | - gpe-beam | [] [] | + gold | | + gpe-aerial | | + gpe-beam | | + gpe-bluetooth | | 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 | [] [] [] [] [] | + 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 | | + grub | [] [] | + gsasl | | + gss | | + gst-plugins-bad | [] | + gst-plugins-base | [] | + gst-plugins-good | [] | + gst-plugins-ugly | [] | + gstreamer | [] [] [] | + gtick | | + gtkam | [] | + gtkorphan | [] | + gtkspell | [] [] [] | + gutenprint | | + hello | [] | + help2man | | + hylafax | | + idutils | | + indent | [] [] | + iso_15924 | | + iso_3166 | [] [] [] [] [] [] [] | + iso_3166_2 | | + iso_4217 | | + iso_639 | [] [] [] [] | + iso_639_3 | | + jwhois | | + kbd | | + keytouch | [] | + keytouch-editor | | + keytouch-keyboa... | [] | + klavaro | [] | + latrine | | + ld | [] | + leafpad | [] [] | + libc | [] [] | + libexif | () | + libextractor | | + libgnutls | | + 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 | [] [] [] | + libgphoto2 | | + libgphoto2_port | | + libgsasl | | + libiconv | [] | + libidn | | + lifelines | | + liferea | [] [] | + lilypond | | + linkdr | [] | + lordsawar | | + lprng | | + lynx | [] | + m4 | | + mailfromd | | + mailutils | | + make | | + man-db | | + man-db-manpages | | + minicom | | + mkisofs | | + myserver | | + nano | [] [] | + opcodes | | + parted | | + pies | | + popt | | + psmisc | | + pspp | [] | pwdutils | | - python | | - qof | [] | - radius | [] [] | - recode | [] [] [] [] [] [] [] [] | - rpm | [] [] | + radius | [] | + recode | [] [] | + rosegarden | | + rpm | | + rush | | + sarg | | screem | | - scrollkeeper | [] [] [] | - sed | [] [] [] [] [] | - sh-utils | [] [] [] [] [] [] [] | - shared-mime-info | [] [] [] [] [] [] | - sharutils | [] [] [] [] [] [] [] [] | + scrollkeeper | [] [] [] | + sed | [] [] | + sharutils | [] [] | shishi | | - silky | [] | - skencil | [] [] | - sketch | [] [] | - solfege | [] | - soundtracker | [] [] [] | - sp | [] | - stardict | [] | - system-tools-ba... | [] [] [] [] [] [] [] [] | - tar | [] [] [] [] [] [] [] | - texinfo | [] [] | - textutils | [] [] [] [] [] | - tin | [] () | - tp-robot | [] [] [] [] | - tuxpaint | [] [] | + skencil | | + solfege | | + solfege-manual | | + soundtracker | | + sp | | + sysstat | | + tar | [] | + texinfo | | + tin | | unicode-han-tra... | | - unicode-transla... | [] [] | - util-linux | [] [] [] [] [] [] [] | - vorbis-tools | [] [] | - wastesedge | () | - wdiff | [] [] [] [] [] [] [] [] | - wget | [] [] [] [] [] [] [] [] | - xchat | [] [] [] [] [] [] [] [] | - xkeyboard-config | [] [] [] [] | - xpad | [] [] [] | + unicode-transla... | | + util-linux-ng | [] | + vice | | + vmm | | + vorbis-tools | | + wastesedge | | + wdiff | | + wget | [] [] | + wyslij-po | | + xchat | [] [] [] [] | + xdg-user-dirs | [] [] [] [] [] [] [] [] [] | + xkeyboard-config | [] [] | +--------------------------------------------------+ - 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 + af am an ar as ast az be be@latin bg bn_IN bs ca + 6 0 1 2 3 19 1 10 3 28 3 1 38 - ja ko ku ky lg lt lv mk mn ms mt nb ne nl nn no + crh cs da de el en en_GB en_ZA eo es et eu fa +-------------------------------------------------+ - GNUnet | | - a2ps | () [] [] () | - aegis | () | - ant-phone | [] | - anubis | [] [] [] | - ap-utils | [] | - aspell | [] [] | - bash | [] | - batchelor | [] [] | - bfd | | - bibshelf | [] | - binutils | | - bison | [] [] [] | - bison-runtime | [] [] [] | - bluez-pin | [] [] [] | - cflow | | - clisp | [] | - console-tools | | - coreutils | [] | + a2ps | [] [] [] [] [] [] [] | + aegis | [] [] [] | + ant-phone | [] () | + anubis | [] [] | + aspell | [] [] [] [] [] | + bash | [] [] [] | + bfd | [] | + bibshelf | [] [] [] | + binutils | [] | + bison | [] [] | + bison-runtime | [] [] [] [] | + bluez-pin | [] [] [] [] [] [] | + bombono-dvd | [] | + buzztard | [] [] [] | + cflow | [] [] | + clisp | [] [] [] [] | + 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 | [] | + cppi | | + cpplib | [] [] [] | + cryptsetup | [] | + dfarc | [] [] [] | + dialog | [] [] [] [] [] | + dico | | + diffutils | [] [] [] [] [] [] | + dink | [] [] [] | + doodle | [] | + e2fsprogs | [] [] [] | + enscript | [] [] [] | + exif | () [] [] | + fetchmail | [] [] () [] [] [] | + findutils | [] [] [] | + flex | [] [] | + freedink | [] [] [] | + gas | [] | + gawk | [] [] [] | + gcal | [] | + gcc | [] [] | + gettext-examples | [] [] [] [] | + gettext-runtime | [] [] [] [] | + gettext-tools | [] [] [] | + gip | [] [] [] [] | + gjay | [] | + gliv | [] [] [] | + glunarclock | [] [] | + gnubiff | () | + gnucash | [] () () () () | + gnuedu | [] [] | + gnulib | [] [] | + gnunet | | + gnunet-gtk | [] | + gnutls | [] [] | + gold | [] | + gpe-aerial | [] [] [] [] | + gpe-beam | [] [] [] [] | + gpe-bluetooth | [] [] | + 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 | [] | + grub | [] [] | + 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 | | + gst-plugins-bad | [] [] [] [] [] | + gst-plugins-base | [] [] [] [] [] | + gst-plugins-good | [] [] [] [] [] [] | + gst-plugins-ugly | [] [] [] [] [] [] | + gstreamer | [] [] [] [] [] | + gtick | [] () [] | + gtkam | [] [] () [] [] | + gtkorphan | [] [] [] [] | + gtkspell | [] [] [] [] [] [] [] | + gutenprint | [] [] [] | + hello | [] [] [] [] | + help2man | [] | + hylafax | [] [] | + idutils | [] [] | + indent | [] [] [] [] [] [] [] | + iso_15924 | [] () [] [] | + iso_3166 | [] [] [] [] () [] [] [] () | + iso_3166_2 | () | + iso_4217 | [] [] [] () [] [] | + iso_639 | [] [] [] [] () [] [] | + iso_639_3 | [] | + jwhois | [] | + kbd | [] [] [] [] [] | + keytouch | [] [] | + keytouch-editor | [] [] | + keytouch-keyboa... | [] | + klavaro | [] [] [] [] | + 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 | [] [] | + libgnutls | [] | + libgpewidget | [] [] | + libgpg-error | [] [] | + libgphoto2 | [] () | + libgphoto2_port | [] () [] | + libgsasl | | + libiconv | [] [] [] [] [] | + libidn | [] [] [] | + lifelines | [] () | + liferea | [] [] [] [] [] | + lilypond | [] [] [] | + linkdr | [] [] [] | + lordsawar | [] | + lprng | | + lynx | [] [] [] [] | + m4 | [] [] [] [] | + mailfromd | | + mailutils | [] | + make | [] [] [] | + man-db | | + man-db-manpages | | + minicom | [] [] [] [] | + mkisofs | | + myserver | | + nano | [] [] [] | + opcodes | [] [] | + parted | [] [] | + pies | | + popt | [] [] [] [] [] | + psmisc | [] [] [] | + pspp | [] | + pwdutils | [] | + radius | [] | + recode | [] [] [] [] [] [] | + rosegarden | () () () | + rpm | [] [] [] | + rush | | + sarg | | + screem | | + scrollkeeper | [] [] [] [] [] | + sed | [] [] [] [] [] [] | + sharutils | [] [] [] [] | shishi | | - silky | [] | - skencil | | - sketch | | - solfege | | - soundtracker | | - sp | () | - stardict | [] [] | - system-tools-ba... | [] [] [] [] | - tar | [] [] [] | - texinfo | [] [] [] | - textutils | [] [] [] | - tin | | - tp-robot | [] | - tuxpaint | [] | + skencil | [] () [] | + solfege | [] [] [] | + solfege-manual | [] [] | + soundtracker | [] [] [] | + sp | [] | + sysstat | [] [] [] | + tar | [] [] [] [] | + texinfo | [] [] [] | + tin | [] [] | unicode-han-tra... | | unicode-transla... | | - util-linux | [] [] | - vorbis-tools | [] | - wastesedge | [] | - wdiff | [] [] | - wget | [] [] | - xchat | [] [] [] [] | - xkeyboard-config | [] | - xpad | [] [] [] | + util-linux-ng | [] [] [] [] | + vice | () () | + vmm | [] | + vorbis-tools | [] [] | + wastesedge | [] | + wdiff | [] [] | + wget | [] [] [] | + wyslij-po | | + xchat | [] [] [] [] [] | + xdg-user-dirs | [] [] [] [] [] [] [] [] [] | + xkeyboard-config | [] [] [] [] [] [] | +-------------------------------------------------+ - 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 + crh cs da de el en en_GB en_ZA eo es et eu fa + 5 64 105 117 18 1 8 0 28 89 18 19 0 + + fi fr ga gl gu he hi hr hu hy id is it ja ka kn + +----------------------------------------------------+ + a2ps | [] [] [] [] | + aegis | [] [] | + ant-phone | [] [] | + anubis | [] [] [] [] | + aspell | [] [] [] [] | + bash | [] [] [] [] | + bfd | [] [] [] | + bibshelf | [] [] [] [] [] | + binutils | [] [] [] | + bison | [] [] [] [] | + bison-runtime | [] [] [] [] [] [] | + bluez-pin | [] [] [] [] [] [] [] [] | + bombono-dvd | [] | + buzztard | [] | + cflow | [] [] [] | + clisp | [] | + coreutils | [] [] [] [] [] | + cpio | [] [] [] [] | + cppi | [] [] | + cpplib | [] [] [] | + cryptsetup | [] [] [] | + dfarc | [] [] [] | + dialog | [] [] [] [] [] [] [] | + dico | | + diffutils | [] [] [] [] [] [] [] [] [] | + dink | [] | + doodle | [] [] | + e2fsprogs | [] [] | + enscript | [] [] [] [] | + exif | [] [] [] [] [] [] | + fetchmail | [] [] [] [] | + findutils | [] [] [] [] [] [] | + flex | [] [] [] | + freedink | [] [] [] | + gas | [] [] | + gawk | [] [] [] [] () [] | + gcal | [] | + gcc | [] | + gettext-examples | [] [] [] [] [] [] [] | + gettext-runtime | [] [] [] [] [] [] | + gettext-tools | [] [] [] [] | + gip | [] [] [] [] [] [] | + gjay | [] | + gliv | [] () | + glunarclock | [] [] [] [] | + gnubiff | () [] () | + gnucash | () () () () () [] | + gnuedu | [] [] | + gnulib | [] [] [] [] [] [] | + gnunet | | + gnunet-gtk | [] | + gnutls | [] [] | + gold | [] [] | + gpe-aerial | [] [] [] | + gpe-beam | [] [] [] [] | + gpe-bluetooth | [] [] [] [] | + 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 | [] [] | + grub | [] [] [] [] | + gsasl | [] [] [] [] [] | + gss | [] [] [] [] [] | + gst-plugins-bad | [] [] [] [] [] [] | + gst-plugins-base | [] [] [] [] [] [] | + gst-plugins-good | [] [] [] [] [] [] | + gst-plugins-ugly | [] [] [] [] [] [] | + gstreamer | [] [] [] [] [] | + gtick | [] [] [] [] [] | + gtkam | [] [] [] [] [] | + gtkorphan | [] [] [] | + gtkspell | [] [] [] [] [] [] [] [] [] | + gutenprint | [] [] [] [] | + hello | [] [] [] | + help2man | [] [] | + hylafax | [] | + idutils | [] [] [] [] [] [] | + indent | [] [] [] [] [] [] [] [] | + iso_15924 | [] () [] [] | + iso_3166 | [] () [] [] [] [] [] [] [] [] [] [] | + iso_3166_2 | () [] [] [] | + iso_4217 | [] () [] [] [] [] | + iso_639 | [] () [] [] [] [] [] [] [] | + iso_639_3 | () [] [] | + jwhois | [] [] [] [] [] | + kbd | [] [] | + keytouch | [] [] [] [] [] [] | + keytouch-editor | [] [] [] [] [] | + keytouch-keyboa... | [] [] [] [] [] | + klavaro | [] [] | + latrine | [] [] [] | + ld | [] [] [] [] | + leafpad | [] [] [] [] [] [] [] () | + libc | [] [] [] [] [] | + libexif | [] | + libextractor | | + libgnutls | [] [] | + libgpewidget | [] [] [] [] | + libgpg-error | [] [] | + libgphoto2 | [] [] [] | + libgphoto2_port | [] [] [] | + libgsasl | [] [] [] [] [] | + libiconv | [] [] [] [] [] [] | + libidn | [] [] [] [] | + lifelines | () | + liferea | [] [] [] [] | + lilypond | [] [] | + linkdr | [] [] [] [] [] | + lordsawar | | + lprng | [] | + lynx | [] [] [] [] [] | + m4 | [] [] [] [] [] [] | + mailfromd | | + mailutils | [] [] | + make | [] [] [] [] [] [] [] [] [] | + man-db | [] [] | + man-db-manpages | [] | + minicom | [] [] [] [] [] | + mkisofs | [] [] [] [] | + myserver | | + nano | [] [] [] [] [] [] | + opcodes | [] [] [] [] | + parted | [] [] [] [] | + pies | | + popt | [] [] [] [] [] [] [] [] [] | + psmisc | [] [] [] | + pspp | | + pwdutils | [] [] | + radius | [] [] | + recode | [] [] [] [] [] [] [] [] | + rosegarden | () () () () () | + rpm | [] [] | + rush | | + sarg | [] | + screem | [] [] | + scrollkeeper | [] [] [] [] | + sed | [] [] [] [] [] [] [] [] | + sharutils | [] [] [] [] [] [] [] | + shishi | [] | + skencil | [] | + solfege | [] [] [] [] | + solfege-manual | [] [] | + soundtracker | [] [] | + sp | [] () | + sysstat | [] [] [] [] [] | + tar | [] [] [] [] [] [] [] | + texinfo | [] [] [] [] | + tin | [] | + unicode-han-tra... | | + unicode-transla... | [] [] | + util-linux-ng | [] [] [] [] [] [] | + vice | () () () | + vmm | [] | + vorbis-tools | [] | + wastesedge | () () | + wdiff | [] | + wget | [] [] [] [] [] [] [] [] | + wyslij-po | [] [] [] | + xchat | [] [] [] [] [] [] [] [] [] | + xdg-user-dirs | [] [] [] [] [] [] [] [] [] [] [] [] [] | + xkeyboard-config | [] [] [] [] [] | + +----------------------------------------------------+ + fi fr ga gl gu he hi hr hu hy id is it ja ka kn + 105 121 53 20 4 8 3 5 53 2 120 5 84 67 0 4 + + ko ku ky lg lt lv mk ml mn mr ms mt nb nds ne + +-----------------------------------------------+ + a2ps | [] | + aegis | | + ant-phone | | + anubis | [] [] | + aspell | [] | + bash | | + bfd | | + bibshelf | [] [] | + binutils | | + bison | [] | + bison-runtime | [] [] [] [] [] | + bluez-pin | [] [] [] [] [] | + bombono-dvd | | + buzztard | | + cflow | | + clisp | | + coreutils | [] | + cpio | | + cppi | | + cpplib | | + cryptsetup | | + dfarc | [] | + dialog | [] [] [] [] [] | + dico | | + diffutils | [] [] | + dink | | + doodle | | + e2fsprogs | | + enscript | | + exif | [] | + fetchmail | | + findutils | | + flex | | + freedink | [] | + gas | | + gawk | | + gcal | | + gcc | | + gettext-examples | [] [] [] [] | + gettext-runtime | [] | + gettext-tools | [] | + gip | [] [] | + gjay | | + gliv | | + glunarclock | [] | + gnubiff | | + gnucash | () () () () | + gnuedu | | + gnulib | | + gnunet | | + gnunet-gtk | | + gnutls | [] | + gold | | + gpe-aerial | [] | + gpe-beam | [] | + gpe-bluetooth | [] [] | + 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 | | + grub | | + gsasl | | + gss | | + gst-plugins-bad | [] [] [] [] | + gst-plugins-base | [] [] | + gst-plugins-good | [] [] | + gst-plugins-ugly | [] [] [] [] [] | + gstreamer | | + gtick | | + gtkam | [] | + gtkorphan | [] [] | + gtkspell | [] [] [] [] [] [] [] | + gutenprint | | + hello | [] [] [] | + help2man | | + hylafax | | + idutils | | + indent | | + iso_15924 | [] [] | + iso_3166 | [] [] () [] [] [] [] [] | + iso_3166_2 | | + iso_4217 | [] [] | + iso_639 | [] [] | + iso_639_3 | [] | + jwhois | [] | + kbd | | + keytouch | [] | + keytouch-editor | [] | + keytouch-keyboa... | [] | + klavaro | [] | + latrine | [] | + ld | | + leafpad | [] [] [] | + libc | [] | + libexif | | + libextractor | | + libgnutls | [] | + libgpewidget | [] [] | + libgpg-error | | + libgphoto2 | | + libgphoto2_port | | + libgsasl | | + libiconv | | + libidn | | + lifelines | | + liferea | | + lilypond | | + linkdr | | + lordsawar | | + lprng | | + lynx | | + m4 | | + mailfromd | | + mailutils | | + make | [] | + man-db | | + man-db-manpages | | + minicom | [] | + mkisofs | | + myserver | | + nano | [] [] | + opcodes | | + parted | | + pies | | + popt | [] [] [] | + psmisc | | + pspp | | + pwdutils | | + radius | | + recode | | + rosegarden | | + rpm | | + rush | | + sarg | | + screem | | + scrollkeeper | [] [] | + sed | | + sharutils | | + shishi | | + skencil | | + solfege | [] | + solfege-manual | | + soundtracker | | + sp | | + sysstat | [] | + tar | [] | + texinfo | [] | + tin | | + unicode-han-tra... | | + unicode-transla... | | + util-linux-ng | | + vice | | + vmm | | + vorbis-tools | | + wastesedge | | + wdiff | | + wget | [] | + wyslij-po | | + xchat | [] [] [] | + xdg-user-dirs | [] [] [] [] [] [] [] [] | + xkeyboard-config | [] [] [] | + +-----------------------------------------------+ + ko ku ky lg lt lv mk ml mn mr ms mt nb nds ne + 20 5 10 1 13 48 4 2 2 4 24 10 20 3 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 + nl nn or pa pl ps pt pt_BR ro ru rw sk sl sq sr + +---------------------------------------------------+ + a2ps | [] [] [] [] [] [] [] [] | + aegis | [] [] [] | + ant-phone | [] [] | + anubis | [] [] [] | + aspell | [] [] [] [] [] | + bash | [] [] | + bfd | [] | + bibshelf | [] [] | + binutils | [] [] | + bison | [] [] [] | + bison-runtime | [] [] [] [] [] [] [] | + bluez-pin | [] [] [] [] [] [] [] [] | + bombono-dvd | [] () | + buzztard | [] [] | + cflow | [] | + clisp | [] [] | + coreutils | [] [] [] [] [] [] | + cpio | [] [] [] | + cppi | [] | + cpplib | [] | + cryptsetup | [] | + dfarc | [] | + dialog | [] [] [] [] | + dico | [] | + diffutils | [] [] [] [] [] [] | + dink | () | + doodle | [] [] | + e2fsprogs | [] [] | + enscript | [] [] [] [] [] | + exif | [] [] [] () [] | + fetchmail | [] [] [] [] | + findutils | [] [] [] [] [] | + flex | [] [] [] [] [] | + freedink | [] [] | + gas | | + gawk | [] [] [] [] | + gcal | | + gcc | [] | + gettext-examples | [] [] [] [] [] [] [] [] | + gettext-runtime | [] [] [] [] [] [] [] [] [] | + gettext-tools | [] [] [] [] [] [] | + gip | [] [] [] [] [] | + gjay | | + gliv | [] [] [] [] [] [] | + glunarclock | [] [] [] [] [] | + gnubiff | [] () | + gnucash | [] () () () | + gnuedu | [] | + gnulib | [] [] [] [] | + gnunet | | + gnunet-gtk | | + gnutls | [] [] | + gold | | + gpe-aerial | [] [] [] [] [] [] [] | + gpe-beam | [] [] [] [] [] [] [] | + gpe-bluetooth | [] [] | + 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 | [] [] [] [] | + grub | [] [] [] | + gsasl | [] [] [] [] | + gss | [] [] [] | + gst-plugins-bad | [] [] [] [] [] [] | + gst-plugins-base | [] [] [] [] [] | + gst-plugins-good | [] [] [] [] [] | + gst-plugins-ugly | [] [] [] [] [] [] | + gstreamer | [] [] [] [] [] | + gtick | [] [] [] | + gtkam | [] [] [] [] [] [] | + gtkorphan | [] | + gtkspell | [] [] [] [] [] [] [] [] [] [] | + gutenprint | [] [] | + hello | [] [] [] [] | + help2man | [] [] | + hylafax | [] | + idutils | [] [] [] [] [] | + indent | [] [] [] [] [] [] [] | + iso_15924 | [] [] [] [] | + iso_3166 | [] [] [] [] [] () [] [] [] [] [] [] [] [] | + iso_3166_2 | [] [] [] | + iso_4217 | [] [] [] [] [] [] [] [] | + iso_639 | [] [] [] [] [] [] [] [] [] | + iso_639_3 | [] [] | + jwhois | [] [] [] [] | + kbd | [] [] [] | + keytouch | [] [] [] | + keytouch-editor | [] [] [] | + keytouch-keyboa... | [] [] [] | + klavaro | [] [] | + latrine | [] [] | + ld | | + leafpad | [] [] [] [] [] [] [] [] [] | + libc | [] [] [] [] | + libexif | [] [] () [] | + libextractor | | + libgnutls | [] [] | + libgpewidget | [] [] [] | + libgpg-error | [] [] | + libgphoto2 | [] [] | + libgphoto2_port | [] [] [] [] [] | + libgsasl | [] [] [] [] [] | + libiconv | [] [] [] [] [] | + libidn | [] [] | + lifelines | [] [] | + liferea | [] [] [] [] [] () () [] | + lilypond | [] | + linkdr | [] [] [] | + lordsawar | | + lprng | [] | + lynx | [] [] [] | + m4 | [] [] [] [] [] | + mailfromd | [] | + mailutils | [] | + make | [] [] [] [] | + man-db | [] [] [] | + man-db-manpages | [] [] [] | + minicom | [] [] [] [] | + mkisofs | [] [] [] | + myserver | | + nano | [] [] [] [] | + opcodes | [] [] | + parted | [] [] [] [] | + pies | [] | + popt | [] [] [] [] | + psmisc | [] [] [] | + pspp | [] [] | + pwdutils | [] | + radius | [] [] [] | + recode | [] [] [] [] [] [] [] [] | + rosegarden | () () | + rpm | [] [] [] | + rush | [] [] | + sarg | | + screem | | + scrollkeeper | [] [] [] [] [] [] [] [] | + sed | [] [] [] [] [] [] [] [] [] | + sharutils | [] [] [] [] | + shishi | [] | + skencil | [] [] | + solfege | [] [] [] [] | + solfege-manual | [] [] [] | + soundtracker | [] | + sp | | + sysstat | [] [] [] [] | + tar | [] [] [] [] | + texinfo | [] [] [] [] | + tin | [] | + unicode-han-tra... | | + unicode-transla... | | + util-linux-ng | [] [] [] [] [] | + vice | [] | + vmm | [] | + vorbis-tools | [] [] | + wastesedge | [] | + wdiff | [] [] | + wget | [] [] [] [] [] [] [] | + wyslij-po | [] [] [] | + xchat | [] [] [] [] [] [] [] [] [] | + xdg-user-dirs | [] [] [] [] [] [] [] [] [] [] [] [] [] [] | + xkeyboard-config | [] [] [] | + +---------------------------------------------------+ + nl nn or pa pl ps pt pt_BR ro ru rw sk sl sq sr + 135 10 4 7 105 1 29 62 47 91 3 54 46 9 37 - tg th tk tr uk ven vi wa xh zh_CN zh_HK zh_TW zu + sv sw ta te tg th tr uk vi wa zh_CN zh_HK zh_TW +---------------------------------------------------+ - 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 + a2ps | [] [] [] [] [] | 27 + aegis | [] | 9 + ant-phone | [] [] [] [] | 9 + anubis | [] [] [] [] | 15 + aspell | [] [] [] | 20 + bash | [] [] [] | 12 + bfd | [] | 6 + bibshelf | [] [] [] | 16 + binutils | [] [] | 8 + bison | [] [] | 12 + bison-runtime | [] [] [] [] [] [] | 29 + bluez-pin | [] [] [] [] [] [] [] [] | 37 + bombono-dvd | [] | 4 + buzztard | [] | 7 + cflow | [] [] [] | 9 + clisp | | 10 + coreutils | [] [] [] [] | 22 + cpio | [] [] [] [] [] [] | 13 + cppi | [] [] | 5 + cpplib | [] [] [] [] [] [] | 14 + cryptsetup | [] [] | 7 + dfarc | [] | 9 + dialog | [] [] [] [] [] [] [] | 30 + dico | [] | 2 + diffutils | [] [] [] [] [] [] | 30 + dink | | 4 + doodle | [] [] | 7 + e2fsprogs | [] [] [] | 11 + enscript | [] [] [] [] | 17 + exif | [] [] [] | 16 + fetchmail | [] [] [] | 17 + findutils | [] [] [] [] [] | 20 + flex | [] [] [] [] | 15 + freedink | [] | 10 + gas | [] | 4 + gawk | [] [] [] [] | 18 + gcal | [] [] | 5 + gcc | [] [] [] | 7 + gettext-examples | [] [] [] [] [] [] [] | 34 + gettext-runtime | [] [] [] [] [] [] [] | 29 + gettext-tools | [] [] [] [] [] [] | 22 + gip | [] [] [] [] | 22 + gjay | [] | 3 + gliv | [] [] [] | 14 + glunarclock | [] [] [] [] [] | 19 + gnubiff | [] [] | 4 + gnucash | () [] () [] () | 10 + gnuedu | [] [] | 7 + gnulib | [] [] [] [] | 16 + gnunet | [] | 1 + gnunet-gtk | [] [] [] | 5 + gnutls | [] [] [] | 10 + gold | [] | 4 + gpe-aerial | [] [] [] | 18 + gpe-beam | [] [] [] | 19 + gpe-bluetooth | [] [] [] | 13 + gpe-calendar | [] [] [] [] | 12 + gpe-clock | [] [] [] [] [] | 28 + gpe-conf | [] [] [] [] | 20 + gpe-contacts | [] [] [] | 17 + gpe-edit | [] [] [] | 12 + gpe-filemanager | [] [] [] [] | 16 + gpe-go | [] [] [] [] [] | 25 + gpe-login | [] [] [] | 11 + gpe-ownerinfo | [] [] [] [] [] | 25 + gpe-package | [] [] [] | 13 + gpe-sketchbook | [] [] [] | 20 + gpe-su | [] [] [] [] [] | 30 + gpe-taskmanager | [] [] [] [] [] | 29 + gpe-timesheet | [] [] [] [] [] | 25 + gpe-today | [] [] [] [] [] [] | 30 + gpe-todo | [] [] [] [] | 17 + gphoto2 | [] [] [] [] [] | 24 + gprof | [] [] [] | 15 + gpsdrive | [] [] [] | 11 + gramadoir | [] [] [] | 11 + grep | [] [] [] | 10 + grub | [] [] [] | 14 + gsasl | [] [] [] [] | 14 + gss | [] [] [] | 11 + gst-plugins-bad | [] [] [] [] | 26 + gst-plugins-base | [] [] [] [] [] | 24 + gst-plugins-good | [] [] [] [] | 24 + gst-plugins-ugly | [] [] [] [] [] | 29 + gstreamer | [] [] [] [] | 22 + gtick | [] [] [] | 13 + gtkam | [] [] [] | 20 + gtkorphan | [] [] [] | 14 + gtkspell | [] [] [] [] [] [] [] [] [] | 45 + gutenprint | [] | 10 + hello | [] [] [] [] [] [] | 21 + help2man | [] [] | 7 + hylafax | [] | 5 + idutils | [] [] [] [] | 17 + indent | [] [] [] [] [] [] | 30 + iso_15924 | () [] () [] [] | 16 + iso_3166 | [] [] () [] [] () [] [] [] () | 53 + iso_3166_2 | () [] () [] | 9 + iso_4217 | [] () [] [] () [] [] | 26 + iso_639 | [] [] [] () [] () [] [] [] [] | 38 + iso_639_3 | [] () | 8 + jwhois | [] [] [] [] [] | 16 + kbd | [] [] [] [] [] | 15 + keytouch | [] [] [] | 16 + keytouch-editor | [] [] [] | 14 + keytouch-keyboa... | [] [] [] | 14 + klavaro | [] | 11 + latrine | [] [] [] | 10 + ld | [] [] [] [] | 11 + leafpad | [] [] [] [] [] [] | 33 + libc | [] [] [] [] [] | 21 + libexif | [] () | 7 + libextractor | [] | 1 + libgnutls | [] [] [] | 9 + libgpewidget | [] [] [] | 14 + libgpg-error | [] [] [] | 9 + libgphoto2 | [] [] | 8 + libgphoto2_port | [] [] [] [] | 14 + libgsasl | [] [] [] | 13 + libiconv | [] [] [] [] | 21 + libidn | () [] [] | 11 + lifelines | [] | 4 + liferea | [] [] [] | 21 + lilypond | [] | 7 + linkdr | [] [] [] [] [] | 17 + lordsawar | | 1 + lprng | [] | 3 + lynx | [] [] [] [] | 17 + m4 | [] [] [] [] | 19 + mailfromd | [] [] | 3 + mailutils | [] | 5 + make | [] [] [] [] | 21 + man-db | [] [] [] | 8 + man-db-manpages | | 4 + minicom | [] [] | 16 + mkisofs | [] [] | 9 + myserver | | 0 + nano | [] [] [] [] | 21 + opcodes | [] [] [] | 11 + parted | [] [] [] [] [] | 15 + pies | [] [] | 3 + popt | [] [] [] [] [] [] | 27 + psmisc | [] [] | 11 + pspp | | 4 + pwdutils | [] [] | 6 + radius | [] [] | 9 + recode | [] [] [] [] | 28 + rosegarden | () | 0 + rpm | [] [] [] | 11 + rush | [] [] | 4 + sarg | | 1 + screem | [] | 3 + scrollkeeper | [] [] [] [] [] | 27 + sed | [] [] [] [] [] | 30 + sharutils | [] [] [] [] [] | 22 + shishi | [] | 3 + skencil | [] [] | 7 + solfege | [] [] [] [] | 16 + solfege-manual | [] | 8 + soundtracker | [] [] [] | 9 + sp | [] | 3 + sysstat | [] [] | 15 + tar | [] [] [] [] [] [] | 23 + texinfo | [] [] [] [] [] | 17 + tin | | 4 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 + util-linux-ng | [] [] [] [] | 20 + vice | () () | 1 + vmm | [] | 4 + vorbis-tools | [] | 6 + wastesedge | | 2 + wdiff | [] [] | 7 + wget | [] [] [] [] [] | 26 + wyslij-po | [] [] | 8 + xchat | [] [] [] [] [] [] | 36 + xdg-user-dirs | [] [] [] [] [] [] [] [] [] [] | 63 + xkeyboard-config | [] [] [] | 22 +---------------------------------------------------+ - 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 + 85 teams sv sw ta te tg th tr uk vi wa zh_CN zh_HK zh_TW + 178 domains 119 1 3 3 0 10 65 51 155 17 98 7 41 2618 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 @@ -1075,12 +1256,12 @@ distributed as such by its maintainer. There might be an observable lag between the mere existence a PO file and its wide availability in a distribution. - If October 2006 seems to be old, you may fetch a more recent copy of + If June 2010 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'. +`http://translationproject.org/extra/matrix.html'. -1.6 Using `gettext' in new packages +1.5 Using `gettext' in new packages =================================== If you are writing a freely available program and want to @@ -1096,6 +1277,6 @@ the use of `gettext' the only thing missing are the translations. The Free Translation Project is also available for packages which are not developed inside the GNU project. Therefore the information given above applies also for every other Free Software Project. Contact -`translation@iro.umontreal.ca' to make the `.pot' files available to -the translation teams. +`coordinator@translationproject.org' to make the `.pot' files available +to the translation teams. @@ -7,6 +7,85 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes in 3.0.6 (since 3.0.5) +* Notable changes + +** Reimplement dynamic library loading ("dlopening") without libltdl + +Guile used to load dynamic libraries with libltdl, a library provided by +the Libtool project. + +Libltdl provided some compatibility benefits when loading shared +libraries made with older toolchains on older operating systems. +However, no system from the last 10 years or so appears to need such a +thick compatibility layer. + +Besides being an unmaintained dependency of limited utility, libltdl +also has the negative aspect that in its search for libraries to load, +it could swallow useful errors for libraries that are found but not +loadable, instead showing just errors for search path candidates that +are not found. + +Guile now implements dynamic library loading directly in terms of the +standard "dlopen" interface, providing a limited shim for platforms with +similar functionality exposed under different names (MinGW). + +This change has a few practical impacts to Guile users. There is a new +library search path variable, `GUILE_EXTENSIONS_PATH'. Also, errors when +loading a library fails now have better errors. And Guile no longer has +a libltdl dependency. + +Although Guile no longer uses libltdl, for backwards compatibility Guile +still adds `LTDL_LIBRARY_PATH' to the loadable library search path, and +includes ad-hoc logic to support uninstalled dynamically loadable +libraries via also adding the ".libs" subdirectories of +`LTDL_LIBRARY_PATH' elements. See "Foreign Libraries" in the +documentation for a full discussion. + +** New `read' implementation in Scheme + +Guile's `read' procedure has been rewritten in Scheme. Compared to the +C reader (which still exists for bootstrapping reasons), the new +implementation is more maintainable, more secure, more debuggable, all +while faithfully reproducing all quirks from Guile's previous reader +implemented in C. Also, the Scheme reader is finally compatible with +suspendable ports, allowing REPL implementations to be built with +lightweight concurrency packages such as the third-party "Fibers" +library. Calls to `read' from Scheme as well as calls to `scm_read' +from C use the new reader. + +The Scheme implementation is currently about 60% as fast as the +now-inaccessible C implementation, and we hope to close the gap over +time. Bug reports very welcome. + +** Scheme compiler uses `read-syntax' for better debugging + +The new Scheme reader also shares implementation with the new +`read-syntax' procedure, which annotates each datum with source location +information. Guile's compiler can use this to provide better +source-level debugging for Scheme programs. Note that this can slightly +increase compiled file sizes, though this is mitigated by some assembler +optimizations. + +** Syntax objects record source locations + +When compiling a file that defines a macro, the output will usually +include a number of syntax objects as literals. Previously, these +literals had no source information; now they do. This should improve +debugging. + +** Optimized run-time relocations + +The code that patches references between statically-allocated Scheme +data has been optimized to be about 30% shorter than before or so, which +can significantly decrease compiled file size and run-time +initialization latency. + +** Updated Gnulib + +The Gnulib compatibility library has been updated, for the first time +since 2017 or so. We expect no functional change but look forward to +any bug reports. + * New interfaces and functionality ** `call-with-port' @@ -17,6 +96,49 @@ See "Ports" in the manual. See "Bytevector Ports" in the manual. +** `GUILE_EXTENSIONS_PATH' environment variable. + +See "Environment Variables" in the manual. + +** `mkdtemp' and `mkstemp' + +See "File System" in the manual. There is still `mkstemp!' but we +recommend that new code uses `mkstemp', which does not mutate the +contents of the "template" argument string. + +** `(system foreign-library)' module + +See the newly reorganized "Foreign Function Interface", for details. +These new interfaces replace `dynamic-link', `dynamic-pointer' and +similar, which will eventually be deprecated. + +** `read-syntax' + +See "Annotated Scheme Read" in the manual. + +** `syntax-sourcev' +** `quote-syntax' + +** Optimized "eof-object?" + +* Bug fixes + +** Fix reverse-list->string docstring +** Fix R7RS "member" result when no item found +** Fix make-transcoded-port on input+output ports +** Fix many bugs that prevented Guile from building on MinGW +** Fix many bugs that prevented Guile's test suite from running on MinGW + +Thanks to Andrey Ivanov, Rob Browning, Erik Dominikus, Göran Weinholt, +and Michael Gran. + +* New deprecations + +** `dynamic-unlink' + +This function now has no effect; Guile will not unload dynamically +linked modules, as that can destabilize the system. + * Incompatible changes ** `call-with-output-string' closes port on normal exit diff --git a/am/bootstrap.am b/am/bootstrap.am index 2821304ec..acc00c762 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -1,4 +1,4 @@ -## Copyright (C) 2009-2020 Free Software Foundation, Inc. +## Copyright (C) 2009-2021 Free Software Foundation, Inc. ## ## This file is part of GNU Guile. ## @@ -120,6 +120,7 @@ SOURCES = \ system/vm/program.scm \ system/vm/vm.scm \ system/foreign.scm \ + system/foreign-library.scm \ \ language/tree-il/compile-cps.scm \ language/tree-il/cps-primitives.scm \ diff --git a/build-aux/config.rpath b/build-aux/config.rpath index 69988c5b6..17298f234 100755 --- a/build-aux/config.rpath +++ b/build-aux/config.rpath @@ -2,7 +2,7 @@ # Output a system dependent set of variables, describing how to set the # run time search path of shared libraries in an executable. # -# Copyright 1996-2021 Free Software Foundation, Inc. +# Copyright 1996-2010 Free Software Foundation, Inc. # Taken from GNU libtool, 2001 # Originally by Gordon Matzigkeit <gord@gnu.ai.mit.edu>, 1996 # @@ -25,7 +25,7 @@ # 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, +# All known linkers require a `.a' archive for static linking (except MSVC, # which needs '.lib'). libext=a shrext=.so @@ -57,6 +57,13 @@ else aix*) wl='-Wl,' ;; + darwin*) + case $cc_basename in + xlc*) + wl='-Wl,' + ;; + esac + ;; mingw* | cygwin* | pw32* | os2* | cegcc*) ;; hpux9* | hpux10* | hpux11*) @@ -65,7 +72,9 @@ else irix5* | irix6* | nonstopux*) wl='-Wl,' ;; - linux* | k*bsd*-gnu | kopensolaris*-gnu) + newsos6) + ;; + linux* | k*bsd*-gnu) case $cc_basename in ecc*) wl='-Wl,' @@ -76,26 +85,17 @@ else lf95*) wl='-Wl,' ;; - nagfor*) - wl='-Wl,-Wl,,' - ;; - pgcc* | pgf77* | pgf90* | pgf95* | pgfortran*) + pgcc | pgf77 | pgf90) wl='-Wl,' ;; ccc*) wl='-Wl,' ;; - xl* | bgxl* | bgf* | mpixl*) - wl='-Wl,' - ;; como) wl='-lopt=' ;; *) case `$CC -V 2>&1 | sed 5q` in - *Sun\ F* | *Sun*Fortran*) - wl= - ;; *Sun\ C*) wl='-Wl,' ;; @@ -103,24 +103,13 @@ else ;; esac ;; - newsos6) - ;; - *nto* | *qnx*) - ;; osf3* | osf4* | osf5*) wl='-Wl,' ;; rdos*) ;; solaris*) - case $cc_basename in - f77* | f90* | f95* | sunf77* | sunf90* | sunf95*) - wl='-Qoption ld ' - ;; - *) - wl='-Wl,' - ;; - esac + wl='-Wl,' ;; sunos4*) wl='-Qoption ld ' @@ -182,14 +171,15 @@ if test "$with_gnu_ld" = yes; then fi ;; amigaos*) - case "$host_cpu" in - powerpc) - ;; - m68k) - hardcode_libdir_flag_spec='-L$libdir' - hardcode_minus_L=yes - ;; - esac + 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 @@ -208,13 +198,11 @@ if test "$with_gnu_ld" = yes; then ld_shlibs=no fi ;; - haiku*) - ;; interix[3-9]*) hardcode_direct=no hardcode_libdir_flag_spec='${wl}-rpath,$libdir' ;; - gnu* | linux* | tpf* | k*bsd*-gnu | kopensolaris*-gnu) + gnu* | linux* | k*bsd*-gnu) if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then : else @@ -337,14 +325,10 @@ else fi ;; amigaos*) - case "$host_cpu" in - powerpc) - ;; - m68k) - hardcode_libdir_flag_spec='-L$libdir' - hardcode_minus_L=yes - ;; - esac + 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]*) ;; @@ -358,16 +342,29 @@ else ;; darwin* | rhapsody*) hardcode_direct=no - if { case $cc_basename in ifort*) true;; *) test "$GCC" = yes;; esac; }; then + if test "$GCC" = yes ; then : else - ld_shlibs=no + case $cc_basename in + xlc*) + ;; + *) + ld_shlibs=no + ;; + esac fi ;; dgux*) hardcode_libdir_flag_spec='-L$libdir' ;; - freebsd2.[01]*) + freebsd1*) + ld_shlibs=no + ;; + freebsd2.2*) + hardcode_libdir_flag_spec='-R$libdir' + hardcode_direct=yes + ;; + freebsd2*) hardcode_direct=yes hardcode_minus_L=yes ;; @@ -423,8 +420,6 @@ else hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir' hardcode_libdir_separator=: ;; - *nto* | *qnx*) - ;; openbsd*) if test -f /usr/libexec/ld.so; then hardcode_direct=yes @@ -520,12 +515,7 @@ case "$host_os" in library_names_spec='$libname$shrext' ;; amigaos*) - case "$host_cpu" in - powerpc*) - library_names_spec='$libname$shrext' ;; - m68k) - library_names_spec='$libname.a' ;; - esac + library_names_spec='$libname.a' ;; beos*) library_names_spec='$libname$shrext' @@ -544,18 +534,19 @@ case "$host_os" in dgux*) library_names_spec='$libname$shrext' ;; - freebsd[23].*) - library_names_spec='$libname$shrext$versuffix' + freebsd1*) ;; freebsd* | dragonfly*) - library_names_spec='$libname$shrext' + case "$host_os" in + freebsd[123]*) + library_names_spec='$libname$shrext$versuffix' ;; + *) + library_names_spec='$libname$shrext' ;; + esac ;; gnu*) library_names_spec='$libname$shrext' ;; - haiku*) - library_names_spec='$libname$shrext' - ;; hpux9* | hpux10* | hpux11*) case $host_cpu in ia64*) @@ -591,7 +582,7 @@ case "$host_os" in ;; linux*oldld* | linux*aout* | linux*coff*) ;; - linux* | k*bsd*-gnu | kopensolaris*-gnu) + linux* | k*bsd*-gnu) library_names_spec='$libname$shrext' ;; knetbsd*-gnu) @@ -603,7 +594,7 @@ case "$host_os" in newsos6) library_names_spec='$libname$shrext' ;; - *nto* | *qnx*) + nto-qnx*) library_names_spec='$libname$shrext' ;; openbsd*) @@ -634,9 +625,6 @@ case "$host_os" in sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*) library_names_spec='$libname$shrext' ;; - tpf*) - library_names_spec='$libname$shrext' - ;; uts4*) library_names_spec='$libname$shrext' ;; diff --git a/configure.ac b/configure.ac index 81a3b1200..6554e9b9e 100644 --- a/configure.ac +++ b/configure.ac @@ -105,12 +105,8 @@ AC_PROG_LIBTOOL AM_CONDITIONAL([HAVE_SHARED_LIBRARIES], [test "x$enable_shared" = "xyes"]) -dnl Check for libltdl. -AC_LIB_HAVE_LINKFLAGS([ltdl], [], [#include <ltdl.h>], - [lt_dlopenext ("foo");]) -if test "x$HAVE_LIBLTDL" != "xyes"; then - AC_MSG_ERROR([GNU libltdl (Libtool) not found, see README.]) -fi +# Some systems provide dlopen via libc; others require -ldl. +AC_SEARCH_LIBS([dlopen], [dl]) AC_CHECK_PROG(have_makeinfo, makeinfo, yes, no) AM_CONDITIONAL(HAVE_MAKEINFO, test "$have_makeinfo" = yes) @@ -653,22 +649,26 @@ fi AC_CACHE_SAVE dnl GMP tests -AC_LIB_HAVE_LINKFLAGS([gmp], - [], - [#include <gmp.h>], - [mpz_import (0, 0, 0, 0, 0, 0, 0);]) -if test "x$HAVE_LIBGMP" != "xyes"; then - AC_MSG_ERROR([GNU MP 4.1 or greater not found, see README]) -fi +SCM_I_GSC_ENABLE_MINI_GMP=0 +AC_ARG_ENABLE(mini-gmp, + [AS_HELP_STRING([--enable-mini-gmp], + [use mini-gmp instead of the full GMP library])]) -dnl `mpz_inits' and `mpz_clears' appeared in GMP 5.0.0. -save_CPPFLAGS="$CPPFLAGS" -if test "x$LIBGMP_PREFIX" != "x"; then - CPPFLAGS="-I$LIBGMP_PREFIX $CPPFLAGS" +if test "x$enable_mini_gmp" = xyes || test "x$enable_mini_gmp" = xy; then + SCM_I_GSC_ENABLE_MINI_GMP=1 +else + AC_LIB_HAVE_LINKFLAGS([gmp],[],[#include <gmp.h>], [mpz_import (0,0,0,0,0,0,0);]) + if test "x$HAVE_LIBGMP" != "xyes"; then + AC_MSG_ERROR([GNU MP 4.1 or greater not found]) + fi + if test "x$LIBGMP_PREFIX" != "x"; then + CPPFLAGS="-I$LIBGMP_PREFIX $CPPFLAGS" + fi + AC_CHECK_DECLS([mpz_inits], [], [], [[#include <gmp.h>]]) fi -AC_CHECK_DECLS([mpz_inits], [], [], [[#include <gmp.h>]]) -CPPFLAGS="$save_CPPFLAGS" +AC_SUBST([SCM_I_GSC_ENABLE_MINI_GMP]) +AM_CONDITIONAL([USE_MINI_GMP], [test "x$enable_mini_gmp" = "xyes"]) dnl GNU libunistring is checked for by Gnulib's `libunistring' module. if test "x$LTLIBUNISTRING" = "x"; then @@ -711,6 +711,7 @@ dnl i18n tests #fi #AC_CHECK_FUNCS([bindtextdomain textdomain]) AM_GNU_GETTEXT([external], [need-ngettext]) +AM_GNU_GETTEXT_VERSION([0.18.1]) ### Some systems don't declare some functions. On such systems, we ### need to at least provide our own K&R-style declarations. diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index 6718752fa..97326ff76 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.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, 2007, 2010, 2011, 2012, 2013, 2014, 2018 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2010, 2011, 2012, 2013, 2014, 2018, 2021 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -245,35 +245,24 @@ frame. See its source code for more details. @node Source Properties @subsection Source Properties +How best to associate source locations with datums parsed from a port? +The right way to do this is to annotate all components of each parsed +datum. @xref{Annotated Scheme Read}, for more on @code{read-syntax}. + @cindex source properties -As Guile reads in Scheme code from file or from standard input, it -remembers the file name, line number and column number where each -expression begins. These pieces of information are known as the -@dfn{source properties} of the expression. Syntax expanders and the -compiler propagate these source properties to compiled procedures, so -that, if an error occurs when evaluating the transformed expression, -Guile's debugger can point back to the file and location where the -expression originated. - -The way that source properties are stored means that Guile cannot -associate source properties with individual symbols, keywords, -characters, booleans, or small integers. This can be seen by typing -@code{(xxx)} and @code{xxx} at the Guile prompt (where the variable -@code{xxx} has not been defined): +Guile only switched to use @code{read-syntax} in 2021, however. For the +previous thirty years, it used a mechanism known as @dfn{source +properties}. -@example -scheme@@(guile-user)> (xxx) -<unnamed port>:4:1: In procedure module-lookup: -<unnamed port>:4:1: Unbound variable: xxx +As Guile reads in Scheme code from file or from standard input, it can +record the file name, line number and column number where each +expression begins in a side table. -scheme@@(guile-user)> xxx -ERROR: In procedure module-lookup: -ERROR: Unbound variable: xxx -@end example - -@noindent -In the latter case, no source properties were stored, so the error -doesn't have any source information. +The way that this side table associates datums with source properties +has a limitation, however: Guile can only associate source properties +with freshly allocated objects. This notably excludes individual +symbols, keywords, characters, booleans, or small integers. This +limitation finally motivated the switch to @code{read-syntax}. @deffn {Scheme Procedure} supports-source-properties? obj @deffnx {C Function} scm_supports_source_properties_p (obj) @@ -283,7 +272,9 @@ otherwise return #f. The recording of source properties is controlled by the read option named ``positions'' (@pxref{Scheme Read}). This option is switched -@emph{on} by default. +@emph{on} by default. Now that @code{read-syntax} is available, +however, Guile may change the default for this flag to off in the +future. The following procedures can be used to access and set the source properties of read expressions. diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 5e1204c0d..df7623f87 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -13,6 +13,7 @@ loading, evaluating, and compiling Scheme code at run time. @menu * Scheme Syntax:: Standard and extended Scheme syntax. * Scheme Read:: Reading Scheme code. +* Annotated Scheme Read:: Reading Scheme code, for the compiler. * Scheme Write:: Writing Scheme values to a port. * Fly Evaluation:: Procedures for on the fly evaluation. * Compilation:: How to compile Scheme files and procedures. @@ -386,6 +387,57 @@ For more information on the @code{r7rs-symbols} option, see (@pxref{Symbol Read Syntax}). +@node Annotated Scheme Read +@subsection Reading Scheme Code, For the Compiler + +When something goes wrong with a Scheme program, the user will want to +know how to fix it. This starts with identifying where the error +occured: we want to associate a source location with each component part +of source code, and propagate that source location information through +to the compiler or interpreter. + +For that, Guile provides @code{read-syntax}. + +@deffn {Scheme Procedure} read-syntax [port] +Read an s-expression from the input port @var{port}, or from the current +input port if @var{port} is not specified. + +If, after skipping white space and comments, no more bytes are available +from @var{port}, return the end-of-file object. @xref{Binary I/O}. +Otherwise, return an annotated datum. An annotated datum is a syntax +object which associates a source location with a datum. For example: + +@example +(call-with-input-string " foo" read-syntax) +; @result{} #<syntax:unknown file:1:2 foo> +(call-with-input-string "(foo)" read-syntax) +; @result{} +; #<syntax:unknown file:1:0 +; (#<syntax unknown file:1:1 foo>)> +@end example + +As the second example shows, all fields of pairs and vectors are also +annotated, recursively. +@end deffn + +Most users are familiar with syntax objects in the context of macros, +which use syntax objects to associate scope information with +identifiers. @xref{Macros}. Here we use syntax objects to associate +source location information with any datum, but without attaching scope +information. The Scheme compiler (@code{compile}) and the interpreter +(@code{eval}) can accept syntax objects directly as input, allowing them +to associate source information with resulting code. +@xref{Compilation}, and @xref{Fly Evaluation}. + +Note that there is a legacy interface for getting source locations into +the Scheme compiler or interpreter, which is to use a side table that +associates ``source properties'' with each subdatum returned by +@code{read}, instead of wrapping the datums directly as in +@code{read-syntax}. This has the disadvantage of not being able to +annotate all kinds of datums. @xref{Source Properties}, for more +information. + + @node Scheme Write @subsection Writing Scheme Values diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index b0d6c249b..e4c068420 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2016-2017 +@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2016-2017, 2021 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -9,245 +9,208 @@ @cindex foreign function interface @cindex ffi -The more one hacks in Scheme, the more one realizes that there are -actually two computational worlds: one which is warm and alive, that -land of parentheses, and one cold and dead, the land of C and its ilk. - -But yet we as programmers live in both worlds, and Guile itself is half -implemented in C. So it is that Guile's living half pays respect to its -dead counterpart, via a spectrum of interfaces to C ranging from dynamic -loading of Scheme primitives to dynamic binding of stock C library -procedures. +Sometimes you need to use libraries written in C or Rust or some other +non-Scheme language. More rarely, you might need to write some C to +extend Guile. This section describes how to load these ``foreign +libraries'', look up data and functions inside them, and so on. @menu -* Foreign Libraries:: Dynamically linking to libraries. -* Foreign Functions:: Simple calls to C procedures. -* C Extensions:: Extending Guile in C with loadable modules. -* Modules and Extensions:: Loading C extensions into modules. -* Foreign Pointers:: Accessing global variables. -* Dynamic FFI:: Calling arbitrary C functions. +* Foreign Libraries:: Dynamically linking to libraries. +* Foreign Extensions:: Extending Guile in C with loadable modules. +* Foreign Pointers:: Pointers to C data or functions. +* Foreign Types:: Expressing C types in Scheme. +* Foreign Functions:: Simple calls to C procedures. +* Void Pointers and Byte Access:: Pointers into the ether. +* Foreign Structs:: Packing and unpacking structs. +* More Foreign Functions:: Advanced examples. @end menu @node Foreign Libraries @subsection Foreign Libraries -Most modern Unices have something called @dfn{shared libraries}. This -ordinarily means that they have the capability to share the executable -image of a library between several running programs to save memory and -disk space. But generally, shared libraries give a lot of additional -flexibility compared to the traditional static libraries. In fact, -calling them `dynamic' libraries is as correct as calling them `shared'. - -Shared libraries really give you a lot of flexibility in addition to the -memory and disk space savings. When you link a program against a shared -library, that library is not closely incorporated into the final -executable. Instead, the executable of your program only contains -enough information to find the needed shared libraries when the program -is actually run. Only then, when the program is starting, is the final -step of the linking process performed. This means that you need not -recompile all programs when you install a new, only slightly modified -version of a shared library. The programs will pick up the changes -automatically the next time they are run. - -Now, when all the necessary machinery is there to perform part of the -linking at run-time, why not take the next step and allow the programmer -to explicitly take advantage of it from within their program? Of course, -many operating systems that support shared libraries do just that, and -chances are that Guile will allow you to access this feature from within -your Scheme programs. As you might have guessed already, this feature -is called @dfn{dynamic linking}.@footnote{Some people also refer to the -final linking stage at program startup as `dynamic linking', so if you -want to make yourself perfectly clear, it is probably best to use the -more technical term @dfn{dlopening}, as suggested by Gordon Matzigkeit -in his libtool documentation.} - -We titled this section ``foreign libraries'' because although the name -``foreign'' doesn't leak into the API, the world of C really is foreign -to Scheme -- and that estrangement extends to components of foreign -libraries as well, as we see in future sections. - -@deffn {Scheme Procedure} dynamic-link [library] -@deffnx {C Function} scm_dynamic_link (library) -Find the shared library denoted by @var{library} (a string) and link it -into the running Guile application. When everything works out, return a -Scheme object suitable for representing the linked object file. -Otherwise an error is thrown. How object files are searched is system -dependent. - -Guile first tries to load @var{library} as the absolute file name of a shared -library. If that fails, it then falls back to interpret -@var{library} as just the name of some shared library that will be -searched for in the places where shared libraries usually reside, such -as @file{/usr/lib} and @file{/usr/local/lib}. - -@var{library} should not contain an extension such as @code{.so}, unless -@var{library} represents the absolute file name to the shared library. The -correct file name extension for the host operating system is provided -automatically, according to libltdl's rules (@pxref{Libltdl interface, -lt_dlopenext, @code{lt_dlopenext}, libtool, Shared Library Support for -GNU}). - -When @var{library} is omitted, a @dfn{global symbol handle} is returned. This -handle provides access to the symbols available to the program at run-time, -including those exported by the program itself and the shared libraries already -loaded. - -Note that on hosts that use dynamic-link libraries (DLLs), the global -symbol handle may not be able to provide access to symbols from -recursively-loaded DLLs. Only exported symbols from those DLLs directly -loaded by the program may be available. -@end deffn +Just as Guile can load up Scheme libraries at run-time, Guile can also +load some system libraries written in C or other low-level languages. +We refer to these as dynamically-loadable modules as @dfn{foreign +libraries}, to distinguish them from native libraries written in Scheme +or other languages implemented by Guile. +@cindex foreign libraries +@cindex libraries, foreign + +Foreign libraries usually come in two forms. Some foreign libraries are +part of the operating system, such as the compression library +@code{libz}. These shared libraries are built in such a way that many +programs can use their functionality without duplicating their code. +When a program written in C is built, it can declare that it uses a +specific set of shared libraries. +@cindex shared libraries +@cindex libraries, shared +When the program is run, the operating system takes care of locating and +loading the shared libraries. + +The operating system components that can dynamically load and link +shared libraries when a program is run are also available +programmatically during a program's execution. This is the interface +that's most useful for Guile, and this is what we mean in Guile when we +refer to @dfn{dynamic linking}. Dynamic linking at run-time is +sometimes called @dfn{dlopening}, to distinguish it from the dynamic +linking that happens at program start-up. +@cindex dynamic linking +@cindex dlopening + +The other kind of foreign library is sometimes known as a module, +plug-in, bundle, or an extension. These foreign libraries aren't meant +to be linked to by C programs, but rather only to be dynamically loaded +at run-time -- they extend some main program with functionality, but +don't stand on their own. Sometimes a Guile library will implement some +of its functionality in a loadable module. + +In either case, the interface on the Guile side is the same. You load +the interface using @code{load-foreign-library}. The resulting foreign +library object implements a simple lookup interface whereby the user can +get addresses of data or code exported by the library. There is no +facility to inspect foreign libraries; you have to know what's in there +already before you look. + +Routines for loading foreign libraries and accessing their contents are +implemented in the @code{(system foreign-library)} module. -@deffn {Scheme Procedure} dynamic-object? obj -@deffnx {C Function} scm_dynamic_object_p (obj) -Return @code{#t} if @var{obj} is a dynamic library handle, or @code{#f} -otherwise. -@end deffn - -@deffn {Scheme Procedure} dynamic-unlink dobj -@deffnx {C Function} scm_dynamic_unlink (dobj) -Unlink the indicated object file from the application. The -argument @var{dobj} must have been obtained by a call to -@code{dynamic-link}. After @code{dynamic-unlink} has been -called on @var{dobj}, its content is no longer accessible. -@end deffn - -@smallexample -(define libgl-obj (dynamic-link "libGL")) -libgl-obj -@result{} #<dynamic-object "libGL"> -(dynamic-unlink libGL-obj) -libGL-obj -@result{} #<dynamic-object "libGL" (unlinked)> -@end smallexample - -As you can see, after calling @code{dynamic-unlink} on a dynamically -linked library, it is marked as @samp{(unlinked)} and you are no longer -able to use it with @code{dynamic-call}, etc. Whether the library is -really removed from you program is system-dependent and will generally -not happen when some other parts of your program still use it. - -When dynamic linking is disabled or not supported on your system, -the above functions throw errors, but they are still available. - - -@node Foreign Functions -@subsection Foreign Functions +@example +(use-modules (system foreign-library)) +@end example -The most natural thing to do with a dynamic library is to grovel around -in it for a function pointer: a @dfn{foreign function}. -@code{dynamic-func} exists for that purpose. - -@deffn {Scheme Procedure} dynamic-func name dobj -@deffnx {C Function} scm_dynamic_func (name, dobj) -Return a ``handle'' for the func @var{name} in the shared object referred to -by @var{dobj}. The handle can be passed to @code{dynamic-call} to -actually call the function. - -Regardless whether your C compiler prepends an underscore @samp{_} to the global -names in a program, you should @strong{not} include this underscore in -@var{name} since it will be added automatically when necessary. +@deffn {Scheme Procedure} load-foreign-library [library] @ + [#:extensions=system-library-extensions] @ + [#:search-ltdl-library-path?=#t] @ + [#:search-path=search-path] @ + [#:search-system-paths?=#t] [#:lazy?=#t] [#:global=#f] +Find the shared library denoted by @var{library} (a string or @code{#f}) +and link it into the running Guile application. When everything works +out, return a Scheme object suitable for representing the linked object +file. Otherwise an error is thrown. + +If @var{library} argument is omitted, it defaults to @code{#f}. If +@code{library} is false, the resulting foreign library gives access to +all symbols available for dynamic linking in the main binary. + +It is not necessary to include any extension such as @code{.so} in +@var{library}. For each system, Guile has a default set of extensions +that it will try. On GNU systems, the default extension set is just +@code{.so}; on Windows, just @code{.dll}; and on Darwin (Mac OS), it is +@code{.bundle}, @code{.so}, and @code{.dylib}. Pass @code{#:extensions +@var{extensions}} to override the default extensions list. If +@var{library} contains one of the extensions, no extensions are tried, +so it is possible to specify the extension if you know exactly what file +to load. + +Unless @var{library} denotes an absolute file name or otherwise contains +a directory separator (@code{/}, and also @code{\} on Windows), Guile +will search for the library in the directories listed in +@var{search-paths}. The default search path has three components, which +can all be overriden by colon-delimited (semicolon on Windows) +environment variables: + +@table @env +@item GUILE_EXTENSIONS_PATH +This is the main environment variable for users to add directories +containing Guile extensions. The default value has no entries. This +environment variable was added in Guile 3.0.6. +@item LTDL_LIBRARY_PATH +Before Guile 3.0.6, Guile loaded foreign libraries using @code{libltdl}, +the dynamic library loader provided by libtool. This loader used +@env{LTDL_LIBRARY_PATH}, and for backwards compatibility we still +support that path. + +However, @code{libltdl} would not only open @code{.so} (or @code{.dll} +and so on) files, but also the @code{.la} files created by libtool. In +installed libraries -- libraries that are in the target directories of +@code{make install} -- @code{.la} files are never needed, to the extent +that most GNU/Linux distributions remove them entirely. It is +sufficient to just load the @code{.so} (or @code{.dll} and so on) files, +which are always located in the same directory as the @code{.la} files. + +But for uninstalled dynamic libraries, like those in a build tree, the +situation is a bit of a mess. If you have a project that uses libtool +to build libraries -- which is the case for Guile, and for most projects +using autotools -- and you build @file{foo.so} in directory @file{D}, +libtool will put @file{foo.la} in @file{D}, but @file{foo.so} gets put +into @file{D/.libs}. + +Users were mostly oblivious to this situation, as @code{libltdl} had +special logic to be able to read the @code{.la} file to know where to +find the @code{.so}, even from an uninstalled build tree, preventing the +existence of @file{.libs} from leaking out to the user. + +We don't use libltdl now, essentially for flexibility and +error-reporting reasons. But, to keep this old use-case working, if +@var{search-ltdl-library-path?} is true, we add each entry of +@code{LTDL_LIBRARY_PATH} to the default extensions load path, +additionally adding the @file{.libs} subdirextories for each entry, in +case there are @file{.so} files there instead of alongside the +@file{.la} files. +@item GUILE_SYSTEM_EXTENSIONS_PATH +The last path in Guile's search path belongs to Guile itself, and +defaults to the libdir and the extensiondir, in that order. For +example, if you install to @file{/opt/guile}, these would probably be +@file{/opt/guile/lib} and +@code{/opt/guile/lib/guile/@value{EFFECTIVE-VERSION}/extensions}, +respectively. @xref{Parallel Installations}, for more details on +@code{extensionsdir}. +@end table + +Finally, if no library is found in the search path, and if @var{library} +is not absolute and does not include directory separators, and if +@var{search-system-paths?} is true, the operating system may have its +own logic for where to locate @var{library}. For example, on GNU, there +will be a default set of paths (often @file{/usr/lib} and @file{/lib}, +though it depends on the system), and the @code{LD_LIBRARY_PATH} +environment variable can add additional paths. Other operating systems +have other conventions. + +Falling back to the operating system for search is usually not a great +thing; it is a recipe for making programs that work on one machine but +not on others. Still, when wrapping system libraries, it can be the +only way to get things working at all. + +If @var{lazy?} is true (the default), Guile will request the operating +system to resolve symbols used by the loaded library as they are first +used. If @var{global?} is true, symbols defined by the loaded library +will be available when other modules need to resolve symbols; the +default is @code{#f}, which keeps symbols local. @end deffn -Guile has static support for calling functions with no arguments, -@code{dynamic-call}. - -@deffn {Scheme Procedure} dynamic-call func dobj -@deffnx {C Function} scm_dynamic_call (func, dobj) -Call the C function indicated by @var{func} and @var{dobj}. -The function is passed no arguments and its return value is -ignored. When @var{function} is something returned by -@code{dynamic-func}, call that function and ignore @var{dobj}. -When @var{func} is a string , look it up in @var{dynobj}; this -is equivalent to -@smallexample -(dynamic-call (dynamic-func @var{func} @var{dobj}) #f) -@end smallexample +The environment variables mentioned above are parsed when the +foreign-library module is first loaded and bound to parameters. Null +path components, for example the three components of +@env{GUILE_SYSTEM_EXTENSIONS_PATH="::"}, are ignored. + +@deffn {Scheme Parameter} guile-extensions-path +@deffnx {Scheme Parameter} ltdl-library-path +@deffnx {Scheme Parameter} guile-system-extensions-path +Parameters whose initial values are taken from +@env{GUILE_EXTENSIONS_PATH}, @env{LTDL_LIBRARY_PATH}, and +@env{GUILE_SYSTEM_EXTENSIONS_PATH}, respectively. @xref{Parameters}. +The current values of these parameters are used when building the search +path when @code{load-foreign-library} is called, unless the caller +explicitly passes a @code{#:search-path} argument. @end deffn -@code{dynamic-call} is not very powerful. It is mostly intended to be -used for calling specially written initialization functions that will -then add new primitives to Guile. For example, we do not expect that you -will dynamically link @file{libX11} with @code{dynamic-link} and then -construct a beautiful graphical user interface just by using -@code{dynamic-call}. Instead, the usual way would be to write a special -Guile-to-X11 glue library that has intimate knowledge about both Guile -and X11 and does whatever is necessary to make them inter-operate -smoothly. This glue library could then be dynamically linked into a -vanilla Guile interpreter and activated by calling its initialization -function. That function would add all the new types and primitives to -the Guile interpreter that it has to offer. - -(There is actually another, better option: simply to create a -@file{libX11} wrapper in Scheme via the dynamic FFI. @xref{Dynamic FFI}, -for more information.) - -Given some set of C extensions to Guile, the next logical step is to -integrate these glue libraries into the module system of Guile so that -you can load new primitives into a running system just as you can load -new Scheme code. - -@deffn {Scheme Procedure} load-extension lib init -@deffnx {C Function} scm_load_extension (lib, init) -Load and initialize the extension designated by LIB and INIT. -When there is no pre-registered function for LIB/INIT, this is -equivalent to - -@lisp -(dynamic-call INIT (dynamic-link LIB)) -@end lisp - -When there is a pre-registered function, that function is called -instead. - -Normally, there is no pre-registered function. This option exists -only for situations where dynamic linking is unavailable or unwanted. -In that case, you would statically link your program with the desired -library, and register its init function right after Guile has been -initialized. - -As for @code{dynamic-link}, @var{lib} should not contain any suffix such -as @code{.so} (@pxref{Foreign Libraries, dynamic-link}). It -should also not contain any directory components. Libraries that -implement Guile Extensions should be put into the normal locations for -shared libraries. We recommend to use the naming convention -@file{libguile-bla-blum} for a extension related to a module @code{(bla -blum)}. - -The normal way for a extension to be used is to write a small Scheme -file that defines a module, and to load the extension into this -module. When the module is auto-loaded, the extension is loaded as -well. For example, - -@lisp -(define-module (bla blum)) - -(load-extension "libguile-bla-blum" "bla_init_blum") -@end lisp +@deffn {Scheme Procedure} foreign-library? obj +Return @code{#t} if @var{obj} is a foreign library, or @code{#f} +otherwise. @end deffn -@node C Extensions -@subsection C Extensions -The most interesting application of dynamically linked libraries is -probably to use them for providing @emph{compiled code modules} to -Scheme programs. As much fun as programming in Scheme is, every now and -then comes the need to write some low-level C stuff to make Scheme even -more fun. +@node Foreign Extensions +@subsection Foreign Extensions -Not only can you put these new primitives into their own module (see the -previous section), you can even put them into a shared library that is -only then linked to your running Guile image when it is actually -needed. +One way to use shared libraries is to extend Guile. Such loadable +modules generally define one distinguished initialization function that, +when called, will use the @code{libguile} API to define procedures in +the current module. -An example will hopefully make everything clear. Suppose we want to -make the Bessel functions of the C library available to Scheme in the -module @samp{(math bessel)}. First we need to write the appropriate -glue code to convert the arguments and return values of the functions -from Scheme to C and back. Additionally, we need a function that will -add them to the set of Guile primitives. Because this is just an -example, we will only implement this for the @code{j0} function. +Concretely, you might extend Guile with an implementation of the Bessel +function, @code{j0}: @smallexample #include <math.h> @@ -260,211 +223,222 @@ j0_wrapper (SCM x) @} void -init_math_bessel () +init_math_bessel (void) @{ scm_c_define_gsubr ("j0", 1, 0, 0, j0_wrapper); @} @end smallexample -We can already try to bring this into action by manually calling the low -level functions for performing dynamic linking. The C source file needs -to be compiled into a shared library. Here is how to do it on -GNU/Linux, please refer to the @code{libtool} documentation for how to -create dynamically linkable libraries portably. +The C source file would then need to be compiled into a shared library. +On GNU/Linux, the compiler invocation might look like this: @smallexample -gcc -shared -o libbessel.so -fPIC bessel.c +gcc -shared -o bessel.so -fPIC bessel.c @end smallexample -Now fire up Guile: +A good default place to put shared libraries that extend Guile is into +the extensions dir. From the command line or a build script, invoke +@code{pkg-config --variable=extensionsdir +guile-@value{EFFECTIVE-VERSION}} to print the extensions dir. +@xref{Parallel Installations}, for more details. + +Guile can load up @code{bessel.so} via @code{load-extension}. + +@deffn {Scheme Procedure} load-extension lib init +@deffnx {C Function} scm_load_extension (lib, init) +Load and initialize the extension designated by LIB and INIT. +@end deffn + +The normal way for a extension to be used is to write a small Scheme +file that defines a module, and to load the extension into this +module. When the module is auto-loaded, the extension is loaded as +well. For example: @lisp -(define bessel-lib (dynamic-link "./libbessel.so")) -(dynamic-call "init_math_bessel" bessel-lib) -(j0 2) -@result{} 0.223890779141236 +(define-module (math bessel) + #:export (j0)) + +(load-extension "bessel" "init_math_bessel") @end lisp -The filename @file{./libbessel.so} should be pointing to the shared -library produced with the @code{gcc} command above, of course. The -second line of the Guile interaction will call the -@code{init_math_bessel} function which in turn will register the C -function @code{j0_wrapper} with the Guile interpreter under the name -@code{j0}. This function becomes immediately available and we can call -it from Scheme. +This @code{load-extension} invocation loads the @code{bessel} library +via @code{(load-foreign-library "bessel")}, then looks up the +@code{init_math_bessel} symbol in the library, treating it as a function +of no arguments, and calls that function. -Fun, isn't it? But we are only half way there. This is what -@code{apropos} has to say about @code{j0}: +If you decide to put your extension outside the default search path for +@code{load-foreign-library}, probably you should adapt the Scheme module +to specify its absolute path. For example, if you use @code{automake} +to build your extension and place it in @code{$(pkglibdir)}, you might +define a build-parameters module that gets created by the build system: -@smallexample -(apropos "j0") -@print{} (guile-user): j0 #<primitive-procedure j0> -@end smallexample +@example +(define-module (math config) + #:export (extensiondir)) +(define extensiondir "PKGLIBDIR") +@end example + +This file would be @code{config.scm.in}. You would define a @code{make} +rule to substitute in the absolute installed file name: + +@example +config.scm: config.scm.in + sed 's|PKGLIBDIR|$(pkglibdir)|' <$< >$@ +@end example + +Then your @code{(math bessel)} would import @code{(math config)}, then +@code{(load-extension (in-vicinity extensiondir "bessel") +"init_math_bessel")}. -As you can see, @code{j0} is contained in the root module, where all -the other Guile primitives like @code{display}, etc live. In general, -a primitive is put into whatever module is the @dfn{current module} at -the time @code{scm_c_define_gsubr} is called. +An alternate approach would be to rebind the +@code{guile-extensions-path} parameter, or its corresponding environment +variable, but note that changing those parameters applies to other users +of @code{load-foreign-library} as well. -A compiled module should have a specially named @dfn{module init -function}. Guile knows about this special name and will call that -function automatically after having linked in the shared library. For -our example, we replace @code{init_math_bessel} with the following code in -@file{bessel.c}: +Note that the new primitives that the extension adds to Guile with +@code{scm_c_define_gsubr} (@pxref{Primitive Procedures}) or with any of +the other mechanisms are placed into the module that is current when the +@code{scm_c_define_gsubr} is executed, so to be clear about what goes +vwhere it's best to include the @code{load-extension} in a module, as +above. Alternately, the C code can use @code{scm_c_define_module} to +specify which module is being created: @smallexample -void -init_math_bessel (void *unused) +static void +do_init (void *unused) @{ scm_c_define_gsubr ("j0", 1, 0, 0, j0_wrapper); scm_c_export ("j0", NULL); @} void -scm_init_math_bessel_module () +init_math_bessel () @{ - scm_c_define_module ("math bessel", init_math_bessel, NULL); + scm_c_define_module ("math bessel", do_init, NULL); @} @end smallexample -The general pattern for the name of a module init function is: -@samp{scm_init_}, followed by the name of the module where the -individual hierarchical components are concatenated with underscores, -followed by @samp{_module}. +And yet... if what we want is just the @code{j0} function, it seems like +a lot of ceremony to have to compile a Guile-specific wrapper library +complete with an initialization function and wraper module to allow +Guile users to call it. There is another way, but to get there, we have +to talk about function pointers and function types first. @xref{Foreign +Functions}, to skip to the good parts. -After @file{libbessel.so} has been rebuilt, we need to place the shared -library into the right place. -Once the module has been correctly installed, it should be possible to -use it like this: - -@smallexample -guile> (load-extension "./libbessel.so" "scm_init_math_bessel_module") -guile> (use-modules (math bessel)) -guile> (j0 2) -0.223890779141236 -guile> (apropos "j0") -@print{} (math bessel): j0 #<primitive-procedure j0> -@end smallexample - -That's it! +@node Foreign Pointers +@subsection Foreign Pointers +Foreign libraries are essentially key-value mappings, where the keys are +names of definitions and the values are the addresses of those +definitions. To look up the address of a definition, use +@code{foreign-library-pointer} from the @code{(system foreign-library)} +module. -@node Modules and Extensions -@subsection Modules and Extensions +@deffn {Scheme Procedure} foreign-library-pointer lib name +Return a ``wrapped pointer'' for the symbol @var{name} in the shared +object referred to by @var{lib}. The returned pointer points to a C +object. -The new primitives that you add to Guile with @code{scm_c_define_gsubr} -(@pxref{Primitive Procedures}) or with any of the other mechanisms are -placed into the module that is current when the -@code{scm_c_define_gsubr} is executed. Extensions loaded from the REPL, -for example, will be placed into the @code{(guile-user)} module, if the -REPL module was not changed. +As a convenience, if @var{lib} is not a foreign library, it will be +passed to @code{load-foreign-library}. +@end deffn -To define C primitives within a specific module, the simplest way is: +If we continue with the @code{bessel.so} example from before, we can get +the address of the @code{init_math_bessel} function via: @example -(define-module (foo bar)) -(load-extension "foobar-c-code" "foo_bar_init") +(use-modules (system foreign-library)) +(define init (foreign-library-pointer "bessel" "init_math_bessel")) +init +@result{} #<pointer 0x7fb35b1b4688> @end example -@cindex extensiondir -When loaded with @code{(use-modules (foo bar))}, the -@code{load-extension} call looks for the @file{foobar-c-code.so} (etc) -object file in Guile's @code{extensiondir}, which is usually a -subdirectory of the @code{libdir}. For example, if your libdir is -@file{/usr/lib}, the @code{extensiondir} for the Guile @value{EFFECTIVE-VERSION}.@var{x} -series will be @file{/usr/lib/guile/@value{EFFECTIVE-VERSION}/}. - -The extension path includes the major and minor version of Guile (the -``effective version''), because Guile guarantees compatibility within a -given effective version. This allows you to install different versions -of the same extension for different versions of Guile. - -If the extension is not found in the @code{extensiondir}, Guile will -also search the standard system locations, such as @file{/usr/lib} or -@file{/usr/local/lib}. It is preferable, however, to keep your extension -out of the system library path, to prevent unintended interference with -other dynamically-linked C libraries. - -If someone installs your module to a non-standard location then the -object file won't be found. You can address this by inserting the -install location in the @file{foo/bar.scm} file. This is convenient -for the user and also guarantees the intended object is read, even if -stray older or newer versions are in the loader's path. - -The usual way to specify an install location is with a @code{prefix} -at the configure stage, for instance @samp{./configure prefix=/opt} -results in library files as say @file{/opt/lib/foobar-c-code.so}. -When using Autoconf (@pxref{Top, , Introduction, autoconf, The GNU -Autoconf Manual}), the library location is in a @code{libdir} -variable. Its value is intended to be expanded by @command{make}, and -can by substituted into a source file like @file{foo.scm.in} +A value returned by @code{foreign-library-pointer} is a Scheme wrapper +for a C pointer. Pointers are a data type in Guile that is disjoint +from all other types. The next section discusses ways to dereference +pointers, but before then we describe the usual type predicates and so +on. + +Note that the rest of the interfaces in this section are part of the +@code{(system foreign)} library: @example -(define-module (foo bar)) -(load-extension "XXextensiondirXX/foobar-c-code" "foo_bar_init") +(use-modules (system foreign)) @end example -@noindent -with the following in a @file{Makefile}, using @command{sed} -(@pxref{Top, , Introduction, sed, SED, A Stream Editor}), +@deffn {Scheme Procedure} pointer-address pointer +@deffnx {C Function} scm_pointer_address (pointer) +Return the numerical value of @var{pointer}. @example -foo.scm: foo.scm.in - sed 's|XXextensiondirXX|$(libdir)/guile/@value{EFFECTIVE-VERSION}|' <foo.scm.in >foo.scm +(pointer-address init) +@result{} 139984413364296 ; YMMV @end example +@end deffn -The actual pattern @code{XXextensiondirXX} is arbitrary, it's only something -which doesn't otherwise occur. If several modules need the value, it -can be easier to create one @file{foo/config.scm} with a define of the -@code{extensiondir} location, and use that as required. +@deffn {Scheme Procedure} make-pointer address [finalizer] +Return a foreign pointer object pointing to @var{address}. If +@var{finalizer} is passed, it should be a pointer to a one-argument C +function that will be called when the pointer object becomes +unreachable. +@end deffn -@example -(define-module (foo config)) -(define-public foo-config-extensiondir "XXextensiondirXX"") -@end example +@deffn {Scheme Procedure} pointer? obj +Return @code{#t} if @var{obj} is a pointer object, or @code{#f} +otherwise. +@end deffn -Such a file might have other locations too, for instance a data -directory for auxiliary files, or @code{localedir} if the module has -its own @code{gettext} message catalogue -(@pxref{Internationalization}). +@defvr {Scheme Variable} %null-pointer +A foreign pointer whose value is 0. +@end defvr -It will be noted all of the above requires that the Scheme code to be -found in @code{%load-path} (@pxref{Load Paths}). Presently it's left up -to the system administrator or each user to augment that path when -installing Guile modules in non-default locations. But having reached -the Scheme code, that code should take care of hitting any of its own -private files etc. +@deffn {Scheme Procedure} null-pointer? pointer +Return @code{#t} if @var{pointer} is the null pointer, @code{#f} otherwise. +@end deffn +For the purpose of passing SCM values directly to foreign functions, and +allowing them to return SCM values, Guile also supports some unsafe +casting operators. -@node Foreign Pointers -@subsection Foreign Pointers +@deffn {Scheme Procedure} scm->pointer scm +Return a foreign pointer object with the @code{object-address} +of @var{scm}. +@end deffn -The previous sections have shown how Guile can be extended at runtime by -loading compiled C extensions. This approach is all well and good, but -wouldn't it be nice if we didn't have to write any C at all? This -section takes up the problem of accessing C values from Scheme, and the -next discusses C functions. +@deffn {Scheme Procedure} pointer->scm pointer +Unsafely cast @var{pointer} to a Scheme object. +Cross your fingers! +@end deffn -@menu -* Foreign Types:: Expressing C types in Scheme. -* Foreign Variables:: Pointers to C symbols. -* Void Pointers and Byte Access:: Pointers into the ether. -* Foreign Structs:: Packing and unpacking structs. -@end menu +Sometimes you want to give C extensions access to the dynamic FFI. At +that point, the names get confusing, because ``pointer'' can refer to a +@code{SCM} object that wraps a pointer, or to a @code{void*} value. We +will try to use ``pointer object'' to refer to Scheme objects, and +``pointer value'' to refer to @code{void *} values. -@node Foreign Types -@subsubsection Foreign Types +@deftypefn {C Function} SCM scm_from_pointer (void *ptr, void (*finalizer) (void*)) +Create a pointer object from a pointer value. -The first impedance mismatch that one sees between C and Scheme is that -in C, the storage locations (variables) are typed, but in Scheme types -are associated with values, not variables. @xref{Values and Variables}. +If @var{finalizer} is non-null, Guile arranges to call it on the pointer +value at some point after the pointer object becomes collectable. +@end deftypefn -So when describing a C function or a C structure so that it can be -accessed from Scheme, the data types of the parameters or fields must be -passed explicitly. +@deftypefn {C Function} void* scm_to_pointer (SCM obj) +Unpack the pointer value from a pointer object. +@end deftypefn -These ``C type values'' may be constructed using the constants and +@node Foreign Types +@subsection Foreign Types + +From Scheme's perspective, foreign pointers are shards of chaos. The +user can create a foreign pointer for any address, and do with it what +they will. The only thing that lends a sense of order to the whole is a +shared hallucination that certain storage locations have certain types. +When making Scheme wrappers for foreign interfaces, we hide the madness +by explicitly representing the the data types of parameters and fields. + +These ``foreign type values'' may be constructed using the constants and procedures from the @code{(system foreign)} module, which may be loaded like this: @@ -473,7 +447,7 @@ like this: @end example @code{(system foreign)} exports a number of values expressing the basic -C types: +C types. @defvr {Scheme Variable} int8 @defvrx {Scheme Variable} uint8 @@ -490,7 +464,7 @@ signednesses. @end defvr In addition there are some convenience bindings for indicating types of -platform-dependent size: +platform-dependent size. @defvr {Scheme Variable} int @defvrx {Scheme Variable} unsigned-int @@ -517,101 +491,81 @@ In addition, the symbol @code{*} is used by convention to denote pointer types. Procedures detailed in the following sections, such as @code{pointer->procedure}, accept it as a type descriptor. -@node Foreign Variables -@subsubsection Foreign Variables - -Pointers to variables in the current address space may be looked up -dynamically using @code{dynamic-pointer}. - -@deffn {Scheme Procedure} dynamic-pointer name dobj -@deffnx {C Function} scm_dynamic_pointer (name, dobj) -Return a ``wrapped pointer'' for the symbol @var{name} in the shared -object referred to by @var{dobj}. The returned pointer points to a C -object. - -Regardless whether your C compiler prepends an underscore @samp{_} to the global -names in a program, you should @strong{not} include this underscore in -@var{name} since it will be added automatically when necessary. -@end deffn +@node Foreign Functions +@subsection Foreign Functions -For example, currently Guile has a variable, @code{scm_numptob}, as part -of its API. It is declared as a C @code{long}. So, to create a handle -pointing to that foreign value, we do: +The most natural thing to do with a dynamic library is to grovel around +in it for a function pointer: a @dfn{foreign function}. Load the +@code{(system foreign)} module to use these Scheme interfaces. @example (use-modules (system foreign)) -(define numptob (dynamic-pointer "scm_numptob" (dynamic-link))) -numptob -@result{} #<pointer 0x7fb35b1b4688> @end example -(The next section discusses ways to dereference pointers.) - -A value returned by @code{dynamic-pointer} is a Scheme wrapper for a C -pointer. +@deffn {Scheme Procedure} pointer->procedure return_type func_ptr arg_types @ + [#:return-errno?=#f] +@deffnx {C Function} scm_pointer_to_procedure (return_type, func_ptr, arg_types) +@deffnx {C Function} scm_pointer_to_procedure_with_errno (return_type, func_ptr, arg_types) -@deffn {Scheme Procedure} pointer-address pointer -@deffnx {C Function} scm_pointer_address (pointer) -Return the numerical value of @var{pointer}. +Make a foreign function. -@example -(pointer-address numptob) -@result{} 139984413364296 ; YMMV -@end example -@end deffn +Given the foreign void pointer @var{func_ptr}, its argument and +return types @var{arg_types} and @var{return_type}, return a +procedure that will pass arguments to the foreign function +and return appropriate values. -@deffn {Scheme Procedure} make-pointer address [finalizer] -Return a foreign pointer object pointing to @var{address}. If -@var{finalizer} is passed, it should be a pointer to a one-argument C -function that will be called when the pointer object becomes -unreachable. -@end deffn +@var{arg_types} should be a list of foreign types. +@code{return_type} should be a foreign type. @xref{Foreign Types}, for +more information on foreign types. -@deffn {Scheme Procedure} pointer? obj -Return @code{#t} if @var{obj} is a pointer object, @code{#f} otherwise. +If @var{return-errno?} is true, or when calling +@code{scm_pointer_to_procedure_with_errno}, the returned procedure will +return two values, with @code{errno} as the second value. @end deffn -@defvr {Scheme Variable} %null-pointer -A foreign pointer whose value is 0. -@end defvr +Finally, in @code{(system foreign-library)} there is a convenient +wrapper function, joining together @code{foreign-libary-pointer} and +@code{procedure->pointer}: -@deffn {Scheme Procedure} null-pointer? pointer -Return @code{#t} if @var{pointer} is the null pointer, @code{#f} otherwise. -@end deffn +@deffn {Scheme Procedure} foreign-library-function lib name @ + [#:return-type=void] [#:arg-types='()] [#:return-errno?=#f] +Load the address of @var{name} from @var{lib}, and treat it as a +function taking arguments @var{arg-types} and returning +@var{return-type}, optionally also with errno. -For the purpose of passing SCM values directly to foreign functions, and -allowing them to return SCM values, Guile also supports some unsafe -casting operators. - -@deffn {Scheme Procedure} scm->pointer scm -Return a foreign pointer object with the @code{object-address} -of @var{scm}. +An invocation of @code{foreign-library-function} is entirely equivalent +to: +@example +(pointer->procedure @var{return-type} + (foreign-library-pointer @var{lib} @var{name}) + @var{arg-types} + #:return-errno? @var{return-errno?}). +@end example @end deffn -@deffn {Scheme Procedure} pointer->scm pointer -Unsafely cast @var{pointer} to a Scheme object. -Cross your fingers! -@end deffn +Pulling all this together, here is a better definition of @code{(math +bessel)}: -Sometimes you want to give C extensions access to the dynamic FFI. At -that point, the names get confusing, because ``pointer'' can refer to a -@code{SCM} object that wraps a pointer, or to a @code{void*} value. We -will try to use ``pointer object'' to refer to Scheme objects, and -``pointer value'' to refer to @code{void *} values. +@example +(define-module (math bessel) + #:use-module (system foreign) + #:use-module (system foreign-library) + #:export (j0)) -@deftypefn {C Function} SCM scm_from_pointer (void *ptr, void (*finalizer) (void*)) -Create a pointer object from a pointer value. +(define j0 + (foreign-library-function "libm" "j0" + #:return-type double + #:arg-types (list double))) +@end example -If @var{finalizer} is non-null, Guile arranges to call it on the pointer -value at some point after the pointer object becomes collectable. -@end deftypefn +That's it! No C at all. -@deftypefn {C Function} void* scm_to_pointer (SCM obj) -Unpack the pointer value from a pointer object. -@end deftypefn +Before going on to more detailed examples, the next two sections discuss +how to deal with data that is more complex than, say, @code{int8}. +@xref{More Foreign Functions}, to continue with foreign function examples. @node Void Pointers and Byte Access -@subsubsection Void Pointers and Byte Access +@subsection Void Pointers and Byte Access Wrapped pointers are untyped, so they are essentially equivalent to C @code{void} pointers. As in C, the memory region pointed to by a @@ -620,6 +574,12 @@ pointer can be accessed at the byte level. This is achieved using module contains procedures that can be used to convert byte sequences to Scheme objects such as strings, floating point numbers, or integers. +Load the @code{(system foreign)} module to use these Scheme interfaces. + +@example +(use-modules (system foreign)) +@end example + @deffn {Scheme Procedure} pointer->bytevector pointer len [offset [uvec_type]] @deffnx {C Function} scm_pointer_to_bytevector (pointer, len, offset, uvec_type) Return a bytevector aliasing the @var{len} bytes pointed to by @@ -709,19 +669,17 @@ pointers to manipulate them. We could write: (define grab-bottle ;; Wrapper for `bottle_t *grab (void)'. - (let ((grab (pointer->procedure '* - (dynamic-func "grab_bottle" libbottle) - '()))) + (let ((grab (foreign-library-function libbottle "grab_bottle" + #:return-type '*))) (lambda () "Return a new bottle." (wrap-bottle (grab))))) (define bottle-contents ;; Wrapper for `const char *bottle_contents (bottle_t *)'. - (let ((contents (pointer->procedure '* - (dynamic-func "bottle_contents" - libbottle) - '(*)))) + (let ((contents (foreign-library-function libbottle "bottle_contents" + #:return-type '* + #:arg-types '(*)))) (lambda (b) "Return the contents of B." (pointer->string (contents (unwrap-bottle b)))))) @@ -736,12 +694,16 @@ In this example, @code{grab-bottle} is guaranteed to return a genuine @code{bottle} object. @end deffn -Going back to the @code{scm_numptob} example above, here is how we can -read its value as a C @code{long} integer: +As another example, currently Guile has a variable, @code{scm_numptob}, +as part of its API. It is declared as a C @code{long}. So, to read its +value, we can do: @example +(use-modules (system foreign)) (use-modules (rnrs bytevectors)) - +(define numptob + (foreign-library-pointer #f "scm_numptob")) +numptob (bytevector-uint-ref (pointer->bytevector numptob (sizeof long)) 0 (native-endianness) (sizeof long)) @@ -756,13 +718,17 @@ crash your program, simply accessing the data pointed to by a dangling pointer or similar can prove equally disastrous. @node Foreign Structs -@subsubsection Foreign Structs +@subsection Foreign Structs Finally, one last note on foreign values before moving on to actually calling foreign functions. Sometimes you need to deal with C structs, which requires interpreting each element of the struct according to the -its type, offset, and alignment. Guile has some primitives to support -this. +its type, offset, and alignment. The @code{(system foreign)} module has +some primitives to support this. + +@example +(use-modules (system foreign)) +@end example @deffn {Scheme Procedure} sizeof type @deffnx {C Function} scm_sizeof (type) @@ -818,67 +784,20 @@ and @code{pointer->bytevector} routines, one can create and parse tightly packed structs and unions by hand. See the code for @code{(system foreign)} for details. +@node More Foreign Functions +@subsection More Foreign Functions -@node Dynamic FFI -@subsection Dynamic FFI - -Of course, the land of C is not all nouns and no verbs: there are -functions too, and Guile allows you to call them. - -@deffn {Scheme Procedure} pointer->procedure return_type func_ptr arg_types @ - [#:return-errno?=#f] -@deffnx {C Function} scm_pointer_to_procedure (return_type, func_ptr, arg_types) -@deffnx {C Function} scm_pointer_to_procedure_with_errno (return_type, func_ptr, arg_types) - -Make a foreign function. - -Given the foreign void pointer @var{func_ptr}, its argument and -return types @var{arg_types} and @var{return_type}, return a -procedure that will pass arguments to the foreign function -and return appropriate values. - -@var{arg_types} should be a list of foreign types. -@code{return_type} should be a foreign type. @xref{Foreign Types}, for -more information on foreign types. - -If @var{return-errno?} is true, or when calling -@code{scm_pointer_to_procedure_with_errno}, the returned procedure will -return two values, with @code{errno} as the second value. -@end deffn - -Here is a better definition of @code{(math bessel)}: - -@example -(define-module (math bessel) - #:use-module (system foreign) - #:export (j0)) - -(define libm (dynamic-link "libm")) - -(define j0 - (pointer->procedure double - (dynamic-func "j0" libm) - (list double))) -@end example - -That's it! No C at all. - -Numeric arguments and return values from foreign functions are -represented as Scheme values. For example, @code{j0} in the above -example takes a Scheme number as its argument, and returns a Scheme -number. - -Pointers may be passed to and returned from foreign functions as well. -In that case the type of the argument or return value should be the -symbol @code{*}, indicating a pointer. For example, the following +It is possible to pass pointers to foreign functions, and to return them +as well. In that case the type of the argument or return value should +be the symbol @code{*}, indicating a pointer. For example, the following code makes @code{memcpy} available to Scheme: @example +(use-modules (system foreign)) (define memcpy - (let ((this (dynamic-link))) - (pointer->procedure '* - (dynamic-func "memcpy" this) - (list '* '* size_t)))) + (foreign-library-function #f "memcpy" + #:return-type '* + #:arg-types (list '* '* size_t))) @end example To invoke @code{memcpy}, one must pass it foreign pointers: @@ -914,10 +833,9 @@ by the foreign pointer is mutated in place. ;; assuming fields are of type "long" (define gettimeofday - (let ((f (pointer->procedure - int - (dynamic-func "gettimeofday" (dynamic-link)) - (list '* '*))) + (let ((f (foreign-library-function #f "gettimeofday" + #:return-type int + #:arg-types (list '* '*))) (tv-type (list long long))) (lambda () (let* ((timeval (make-c-struct tv-type (list 0 0))) @@ -955,10 +873,8 @@ function can be made accessible to Scheme (@pxref{Array Sort Function, @example (define qsort! - (let ((qsort (pointer->procedure void - (dynamic-func "qsort" - (dynamic-link)) - (list '* size_t size_t '*)))) + (let ((qsort (foreign-library-function + #f "qsort" #:arg-types (list '* size_t size_t '*)))) (lambda (bv compare) ;; Sort bytevector BV in-place according to comparison ;; procedure COMPARE. diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index 83345a2f5..23f9a13ef 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2009-2015, 2018 +@c Copyright (C) 1996, 1997, 2000-2004, 2009-2015, 2018, 2021 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -638,9 +638,25 @@ won't have access to the binding of @code{it}. But they can, if we explicitly introduce a binding via @code{datum->syntax}. -@deffn {Scheme Procedure} datum->syntax template-id datum -Create a syntax object that wraps @var{datum}, within the lexical context -corresponding to the identifier @var{template-id}. +@deffn {Scheme Procedure} datum->syntax template-id datum [#:source=#f] +Create a syntax object that wraps @var{datum}, within the lexical +context corresponding to the identifier @var{template-id}. If +@var{template-id} is false, the datum will have no lexical context +information. + +Syntax objects have an associated source location. Internally this is +represented as a 3-element vector of filename, line, and column. +Usually this location ultimately is provided by @code{read-syntax}; +@xref{Annotated Scheme Read}. + +If a syntax object is passed as @var{source}, the resulting syntax +object will have the source location of @var{source}. Otherwise if +@var{source} is a 3-element source location vector, that vector will be +the source location of the resulting syntax object. If @var{source} is +a source properties alist, those will be parsed and set as the source +location of the resulting syntax object. Otherwise if @var{source} is +false, the source properties are looked up from @code{(source-properties +@var{datum})}. @xref{Source Properties}. @end deffn For completeness, we should mention that it is possible to strip the metadata diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi index 42bbd35f3..ee5f23e50 100644 --- a/doc/ref/guile-invoke.texi +++ b/doc/ref/guile-invoke.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996-1997,2000-2005,2010-2011,2013-2014,2016,2019 +@c Copyright (C) 1996-1997,2000-2005,2010-2011,2013-2014,2016,2019,2021 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -400,6 +400,14 @@ guile -c '(display %load-path) (newline)' (Note: The line breaks, above, are for documentation purposes only, and not required in the actual example.) +@item GUILE_EXTENSIONS_PATH +@vindex GUILE_EXTENSIONS_PATH +This variable may be used to augment the path that is searched for +foreign libraries via @code{load-extension}, @code{dynamic-link}, +@code{load-foreign-library}, or the like. Its value should be a +colon-separated (semicolon on Windows) list of directories. +@xref{Foreign Libraries}. + @item GUILE_WARN_DEPRECATED @vindex GUILE_WARN_DEPRECATED As Guile evolves, some features will be eliminated or replaced by newer diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 9f3fe2d72..660b1ae90 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -13,7 +13,7 @@ @copying This manual documents Guile version @value{VERSION}. -Copyright (C) 1996-1997, 2000-2005, 2009-2020 Free Software Foundation, +Copyright (C) 1996-1997, 2000-2005, 2009-2021 Free Software Foundation, Inc. Permission is granted to copy, distribute and/or modify this document @@ -299,8 +299,6 @@ available through both Scheme and C interfaces. * Initialization:: Initializing Guile. * Snarfing Macros:: Macros for snarfing initialization actions. * Data Types:: Representing values in Guile. -* Foreign Objects:: Defining new data types in C. -* Smobs:: Use foreign objects instead. * Procedures:: Procedures. * Macros:: Extending the syntax of Scheme. * Utility Functions:: General utility functions. @@ -314,6 +312,8 @@ available through both Scheme and C interfaces. * Memory Management:: Memory management and garbage collection. * Modules:: Designing reusable code libraries. * Foreign Function Interface:: Interacting with C procedures and data. +* Foreign Objects:: Defining new data types in C. +* Smobs:: Use foreign objects instead. * Scheduling:: Threads, mutexes, asyncs and dynamic roots. * Options and Config:: Configuration, features and runtime options. * Other Languages:: Emacs Lisp, ECMAScript, and more. @@ -328,8 +328,6 @@ available through both Scheme and C interfaces. @include api-init.texi @include api-snarf.texi @include api-data.texi -@include api-foreign-objects.texi -@include api-smobs.texi @include api-procedures.texi @include api-macros.texi @include api-utility.texi @@ -343,6 +341,8 @@ available through both Scheme and C interfaces. @include api-memory.texi @include api-modules.texi @include api-foreign.texi +@include api-foreign-objects.texi +@include api-smobs.texi @include api-scheduling.texi @c object orientation support here @include api-options.texi diff --git a/doc/ref/libguile-parallel.texi b/doc/ref/libguile-parallel.texi index 75fcd88ba..a3779a2a0 100644 --- a/doc/ref/libguile-parallel.texi +++ b/doc/ref/libguile-parallel.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011, -@c 2013-2014 Free Software Foundation, Inc. +@c 2013-2014, 2021 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Parallel Installations @@ -52,8 +52,8 @@ how to use it from Autoconf. @item extensiondir @cindex @code{extensiondir} The default directory where Guile looks for extensions---i.e., shared -libraries providing additional features (@pxref{Modules and -Extensions}). Run @command{pkg-config guile-@value{EFFECTIVE-VERSION} +libraries providing additional features (@pxref{Foreign Extensions}). +Run @command{pkg-config guile-@value{EFFECTIVE-VERSION} --variable=extensiondir} to see its value. @item guile diff --git a/doc/ref/tour.texi b/doc/ref/tour.texi index 0cac96cbf..c0ecb1699 100644 --- a/doc/ref/tour.texi +++ b/doc/ref/tour.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010, 2011, -@c 2012 Free Software Foundation, Inc. +@c 2012, 2021 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @raisesections @@ -280,7 +280,7 @@ scheme@@(guile-user)> (j0 2) $1 = 0.223890779141236 @end smallexample -@xref{Modules and Extensions}, for more information. +@xref{Foreign Extensions}, for more information. @lowersections diff --git a/libguile.h b/libguile.h index 553b0ec35..14ea1d110 100644 --- a/libguile.h +++ b/libguile.h @@ -22,15 +22,21 @@ -/* This needs to be included outside of the extern "C" block. - */ -#include <gmp.h> - #ifdef __cplusplus extern "C" { #endif - #include "libguile/scm.h" +#ifdef __cplusplus +} +#endif +#if SCM_ENABLE_MINI_GMP +#include "libguile/mini-gmp.h" +#else +#include <gmp.h> +#endif +#ifdef __cplusplus +extern "C" { +#endif #include "libguile/alist.h" #include "libguile/array-handle.h" #include "libguile/array-map.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 8408daac7..c0cc08cbc 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -241,6 +241,10 @@ if ENABLE_JIT libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES += $(lightening_c_files) endif +if USE_MINI_GMP +libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES += mini-gmp.c +endif + DOT_X_FILES = \ alist.x \ array-handle.x \ @@ -474,7 +478,8 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ posix.c net_db.c socket.c \ debug-malloc.c \ posix-w32.c \ - locale-categories.h + locale-categories.h \ + mini-gmp.h ## delete guile-snarf.awk from the installation bindir, in case it's ## lingering there due to an earlier guile version not having been diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 7dfdab499..2d6cbdb3e 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -35,7 +35,13 @@ #include <alloca.h> #include <assert.h> +#include "scm.h" + +#if SCM_ENABLE_MINI_GMP +#include "mini-gmp.h" +#else #include <gmp.h> +#endif #include "array-handle.h" #include "arrays.h" diff --git a/libguile/deprecated.c b/libguile/deprecated.c index fcc4e8343..e4909dfc6 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -1,4 +1,4 @@ -/* Copyright 2003-2004,2006,2008-2018,2020 +/* Copyright 2003-2004,2006,2008-2018,2020,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -31,7 +31,9 @@ #include "boolean.h" #include "bitvectors.h" #include "deprecation.h" +#include "dynl.h" #include "eval.h" +#include "foreign.h" #include "gc.h" #include "gsubr.h" #include "modules.h" @@ -601,6 +603,19 @@ scm_copy_tree (SCM obj) +SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, (SCM obj), "") +#define FUNC_NAME s_scm_dynamic_unlink +{ + scm_c_issue_deprecation_warning + ("scm_dynamic_unlink has no effect and is deprecated. Unloading " + "shared libraries is no longer supported."); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + + void scm_i_init_deprecated () { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index c95f919e5..c68decf74 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -1,7 +1,7 @@ #ifndef SCM_DEPRECATED_H #define SCM_DEPRECATED_H -/* Copyright 2003-2007,2009-2018,2020 +/* Copyright 2003-2007,2009-2018,2020,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -140,6 +140,8 @@ SCM_DEPRECATED SCM scm_make_srcprops (long line, int col, SCM filename, SCM_DEPRECATED SCM scm_copy_tree (SCM obj); +SCM_DEPRECATED SCM scm_dynamic_unlink (SCM obj); + void scm_i_init_deprecated (void); #endif diff --git a/libguile/dynl.c b/libguile/dynl.c index e9c03e95b..8e1cc90d9 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -1,6 +1,6 @@ /* dynl.c - dynamic linking - Copyright 1990-2003,2008-2011,2017-2018 + Copyright 1990-2003,2008-2011,2017-2018,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -28,369 +28,172 @@ # include <config.h> #endif -#include <alloca.h> -#include <stdio.h> -#include <stdlib.h> -#include <string.h> - -#include <ltdl.h> +#include <dlfcn.h> +#include "boolean.h" #include "deprecation.h" -#include "dynwind.h" +#include "eval.h" +#include "extensions.h" #include "foreign.h" -#include "gc.h" #include "gsubr.h" -#include "keywords.h" -#include "libpath.h" #include "list.h" -#include "ports.h" -#include "smob.h" +#include "modules.h" +#include "numbers.h" #include "strings.h" #include "threads.h" +#include "variable.h" +#include "version.h" #include "dynl.h" -/* From the libtool manual: "Note that libltdl is not threadsafe, - i.e. a multithreaded application has to use a mutex for libltdl.". - Note: We initialize it as a recursive mutex below. */ -static scm_i_pthread_mutex_t ltdl_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; - -/* LT_PATH_SEP-separated extension library search path, searched last */ -static char *system_extensions_path; - -static void * -sysdep_dynl_link (const char *fname, const char *subr) -{ - lt_dlhandle handle; - - /* Try the literal filename first or, if NULL, the program itself */ - handle = lt_dlopen (fname); - if (handle == NULL) - { - handle = lt_dlopenext (fname); - - if (handle == NULL -#ifdef LT_DIRSEP_CHAR - && strchr (fname, LT_DIRSEP_CHAR) == NULL -#endif - && strchr (fname, '/') == NULL) - { - /* FNAME contains no directory separators and was not in the - usual library search paths, so now we search for it in - SYSTEM_EXTENSIONS_PATH. */ - char *fname_attempt - = scm_gc_malloc_pointerless (strlen (system_extensions_path) - + strlen (fname) + 2, - "dynl fname_attempt"); - char *path; /* remaining path to search */ - char *end; /* end of current path component */ - char *s; - - /* Iterate over the components of SYSTEM_EXTENSIONS_PATH */ - for (path = system_extensions_path; - *path != '\0'; - path = (*end == '\0') ? end : (end + 1)) - { - /* Find end of path component */ - end = strchr (path, LT_PATHSEP_CHAR); - if (end == NULL) - end = strchr (path, '\0'); - - /* Skip empty path components */ - if (path == end) - continue; - - /* Construct FNAME_ATTEMPT, starting with path component */ - s = fname_attempt; - memcpy (s, path, end - path); - s += end - path; - - /* Append directory separator, but avoid duplicates */ - if (s[-1] != '/' -#ifdef LT_DIRSEP_CHAR - && s[-1] != LT_DIRSEP_CHAR -#endif - ) - *s++ = '/'; - - /* Finally, append FNAME (including null terminator) */ - strcpy (s, fname); - - /* Try to load it, and terminate the search if successful */ - handle = lt_dlopenext (fname_attempt); - if (handle != NULL) - break; - } - } - } - - if (handle == NULL) - { - SCM fn; - SCM msg; - - fn = fname != NULL ? scm_from_locale_string (fname) : SCM_BOOL_F; - msg = scm_from_locale_string (lt_dlerror ()); - scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg)); - } - - return (void *) handle; -} - -static void -sysdep_dynl_unlink (void *handle, const char *subr) -{ - if (lt_dlclose ((lt_dlhandle) handle)) - { - scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL); - } -} - -static void * -sysdep_dynl_value (const char *symb, void *handle, const char *subr) +static SCM +dlerror_string (const char *fallback) { - void *fptr; - - fptr = lt_dlsym ((lt_dlhandle) handle, symb); - if (!fptr) - scm_misc_error (subr, "Symbol not found: ~a", - scm_list_1 (scm_from_locale_string (symb))); - return fptr; + const char *message = dlerror (); + if (message) + return scm_from_locale_string (message); + return scm_from_utf8_string ("Unknown error"); } -static void -sysdep_dynl_init () -{ - char *env; - - lt_dlinit (); - - /* Initialize 'system_extensions_path' from - $GUILE_SYSTEM_EXTENSIONS_PATH, or if that's not set: - <SCM_LIB_DIR> <LT_PATHSEP_CHAR> <SCM_EXTENSIONS_DIR>. - - 'lt_dladdsearchdir' can't be used because it is searched before - the system-dependent search path, which is the one 'libtool - --mode=execute -dlopen' fiddles with (info "(libtool) Libltdl - Interface"). See - <http://lists.gnu.org/archive/html/guile-devel/2010-11/msg00095.html>. - - The environment variables $LTDL_LIBRARY_PATH and $LD_LIBRARY_PATH - can't be used because they would be propagated to subprocesses - which may cause problems for other programs. See - <http://lists.gnu.org/archive/html/guile-devel/2012-09/msg00037.html> */ - - env = getenv ("GUILE_SYSTEM_EXTENSIONS_PATH"); - if (env) - system_extensions_path = env; - else - { - system_extensions_path - = scm_gc_malloc_pointerless (strlen (SCM_LIB_DIR) - + strlen (SCM_EXTENSIONS_DIR) + 2, - "system_extensions_path"); - sprintf (system_extensions_path, "%s%c%s", - SCM_LIB_DIR, LT_PATHSEP_CHAR, SCM_EXTENSIONS_DIR); - } -} - -scm_t_bits scm_tc16_dynamic_obj; - -#define DYNL_FILENAME SCM_SMOB_OBJECT -#define DYNL_HANDLE(x) ((void *) SCM_SMOB_DATA_2 (x)) -#define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v))) - - - -static int -dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate) -{ - scm_puts ("#<dynamic-object ", port); - scm_iprin1 (DYNL_FILENAME (exp), port, pstate); - if (DYNL_HANDLE (exp) == NULL) - scm_puts (" (unlinked)", port); - scm_putc ('>', port); - return 1; -} - - -SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0, - (SCM filename), - "Find the shared object (shared library) denoted by\n" - "@var{filename} and link it into the running Guile\n" - "application. The returned\n" - "scheme object is a ``handle'' for the library which can\n" - "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n" - "Searching for object files is system dependent. Normally,\n" - "if @var{filename} does have an explicit directory it will\n" - "be searched for in locations\n" - "such as @file{/usr/lib} and @file{/usr/local/lib}.\n\n" - "When @var{filename} is omitted, a @dfn{global symbol handle} is\n" - "returned. This handle provides access to the symbols\n" - "available to the program at run-time, including those exported\n" - "by the program itself and the shared libraries already loaded.\n") -#define FUNC_NAME s_scm_dynamic_link +SCM_DEFINE_STATIC (scm_dlopen, "dlopen", 2, 0, 0, (SCM name, SCM flags), "") +#define FUNC_NAME s_scm_dlopen { void *handle; - char *file; + int c_flags = scm_to_int (flags); - scm_dynwind_begin (0); - scm_i_dynwind_pthread_mutex_lock (<dl_lock); - - if (SCM_UNBNDP (filename)) - file = NULL; + if (scm_is_false (name)) + handle = dlopen (NULL, c_flags); else { - file = scm_to_locale_string (filename); - scm_dynwind_free (file); + char *c_name = scm_to_locale_string (name); + handle = dlopen (c_name, c_flags); + free (c_name); } - handle = sysdep_dynl_link (file, FUNC_NAME); - scm_dynwind_end (); + if (!handle) { + SCM message = dlerror_string ("Unknown error while opening module"); + SCM_MISC_ERROR ("file ~S, message ~S", scm_list_2 (name, message)); + } - SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, - SCM_UNBNDP (filename) - ? SCM_UNPACK (SCM_BOOL_F) : SCM_UNPACK (filename), - handle); + return scm_from_pointer (handle, NULL); } #undef FUNC_NAME - -SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a dynamic object handle,\n" - "or @code{#f} otherwise.") -#define FUNC_NAME s_scm_dynamic_object_p +SCM_DEFINE_STATIC (scm_dlclose, "dlclose", 1, 0, 0, (SCM obj), "") +#define FUNC_NAME s_scm_dlclose { - return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj)); -} -#undef FUNC_NAME + void *handle = scm_to_pointer (obj); - -SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, - (SCM dobj), - "Unlink a dynamic object from the application, if possible. The\n" - "object must have been linked by @code{dynamic-link}, with \n" - "@var{dobj} the corresponding handle. After this procedure\n" - "is called, the handle can no longer be used to access the\n" - "object.") -#define FUNC_NAME s_scm_dynamic_unlink -{ - /*fixme* GC-problem */ - SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj); - - scm_dynwind_begin (0); - scm_i_dynwind_pthread_mutex_lock (<dl_lock); - if (DYNL_HANDLE (dobj) == NULL) { - SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj)); - } else { - sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME); - SET_DYNL_HANDLE (dobj, NULL); + if (dlclose (handle) != 0) { + SCM message = dlerror_string ("Unknown error"); + SCM_MISC_ERROR ("Error closing module: ~S", scm_list_1 (message)); } - scm_dynwind_end (); return SCM_UNSPECIFIED; } #undef FUNC_NAME - -SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0, - (SCM name, SCM dobj), - "Return a ``wrapped pointer'' to the symbol @var{name}\n" - "in the shared object referred to by @var{dobj}. The returned\n" - "pointer points to a C object.\n\n" - "Regardless whether your C compiler prepends an underscore\n" - "@samp{_} to the global names in a program, you should\n" - "@strong{not} include this underscore in @var{name}\n" - "since it will be added automatically when necessary.") -#define FUNC_NAME s_scm_dynamic_pointer +SCM_DEFINE_STATIC (scm_dlsym, "dlsym", 2, 0, 0, (SCM obj, SCM name), "") +#define FUNC_NAME s_scm_dlsym { - void *val; + void *handle = scm_to_pointer (obj); + char *c_name = scm_to_utf8_string (name); - SCM_VALIDATE_STRING (1, name); - SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj); + void *sym = dlsym (handle, c_name); + free (c_name); - if (DYNL_HANDLE (dobj) == NULL) - SCM_MISC_ERROR ("Already unlinked: ~S", dobj); - else - { - char *chars; - - scm_dynwind_begin (0); - scm_i_dynwind_pthread_mutex_lock (<dl_lock); - chars = scm_to_locale_string (name); - scm_dynwind_free (chars); - val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME); - scm_dynwind_end (); + if (!sym) { + SCM message = dlerror_string ("Unknown error"); + SCM_MISC_ERROR ("Error resolving ~S: ~S", scm_list_2 (name, message)); + } - return scm_from_pointer (val, NULL); - } + return scm_from_pointer (sym, NULL); } #undef FUNC_NAME +#define DEFINE_LAZY_VAR(c_name, mod_name, sym_name) \ + static SCM c_name##_var; \ + static void init_##c_name##_var (void) \ + { \ + c_name##_var = scm_c_public_lookup (mod_name, sym_name); \ + } \ + static SCM c_name (void) \ + { \ + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; \ + scm_i_pthread_once (&once, init_##c_name##_var); \ + return scm_variable_ref (c_name##_var); \ + } -SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0, - (SCM name, SCM dobj), - "Return a ``handle'' for the function @var{name} in the\n" - "shared object referred to by @var{dobj}. The handle\n" - "can be passed to @code{dynamic-call} to actually\n" - "call the function.\n\n" - "Regardless whether your C compiler prepends an underscore\n" - "@samp{_} to the global names in a program, you should\n" - "@strong{not} include this underscore in @var{name}\n" - "since it will be added automatically when necessary.") -#define FUNC_NAME s_scm_dynamic_func +DEFINE_LAZY_VAR (load_foreign_library, + "system foreign-library", "load-foreign-library"); +DEFINE_LAZY_VAR (foreign_library_p, + "system foreign-library", "foreign-library?"); +DEFINE_LAZY_VAR (foreign_library_pointer, + "system foreign-library", "foreign-library-pointer"); + +SCM +scm_dynamic_link (SCM filename) { - return scm_dynamic_pointer (name, dobj); + return scm_call_1 (load_foreign_library (), filename); } -#undef FUNC_NAME +SCM +scm_dynamic_object_p (SCM obj) +{ + return scm_call_1 (foreign_library_p (), obj); +} -SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0, - (SCM func, SCM dobj), - "Call a C function in a dynamic object. Two styles of\n" - "invocation are supported:\n\n" - "@itemize @bullet\n" - "@item @var{func} can be a function handle returned by\n" - "@code{dynamic-func}. In this case @var{dobj} is\n" - "ignored\n" - "@item @var{func} can be a string with the name of the\n" - "function to call, with @var{dobj} the handle of the\n" - "dynamic object in which to find the function.\n" - "This is equivalent to\n" - "@smallexample\n\n" - "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n" - "@end smallexample\n" - "@end itemize\n\n" - "In either case, the function is passed no arguments\n" - "and its return value is ignored.") -#define FUNC_NAME s_scm_dynamic_call +SCM +scm_dynamic_pointer (SCM name, SCM obj) { - void (*fptr) (void); + return scm_call_2 (foreign_library_pointer (), obj, name); +} - if (scm_is_string (func)) - func = scm_dynamic_func (func, dobj); - SCM_VALIDATE_POINTER (SCM_ARG1, func); +SCM +scm_dynamic_func (SCM name, SCM obj) +{ + return scm_dynamic_pointer (name, obj); +} - fptr = SCM_POINTER_VALUE (func); - fptr (); +SCM +scm_dynamic_call (SCM name, SCM obj) +{ + SCM pointer = scm_dynamic_pointer (name, obj); + void (*f)(void) = SCM_POINTER_VALUE (pointer); + f(); return SCM_UNSPECIFIED; } -#undef FUNC_NAME -void -scm_init_dynamic_linking () +static void +scm_init_system_foreign_library (void *unused) { - scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0); - scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print); + scm_c_define ("RTLD_LAZY", scm_from_int (RTLD_LAZY)); + scm_c_define ("RTLD_NOW", scm_from_int (RTLD_NOW)); + scm_c_define ("RTLD_GLOBAL", scm_from_int (RTLD_GLOBAL)); + scm_c_define ("RTLD_LOCAL", scm_from_int (RTLD_LOCAL)); - /* Make LTDL_LOCK recursive so that a pre-unwind handler can still use - 'dynamic-link', as is the case at the REPL. See - <https://bugs.gnu.org/29275>. */ - scm_i_pthread_mutex_init (<dl_lock, - scm_i_pthread_mutexattr_recursive); - - sysdep_dynl_init (); #include "dynl.x" } + +void +scm_init_dynamic_linking () +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_system_foreign_library", + scm_init_system_foreign_library, + NULL); + + // FIXME: Deprecate all of these, once (system foreign-library) has + // had enough time in the world. + scm_c_define_gsubr + ("dynamic-link", 0, 1, 0, (scm_t_subr) scm_dynamic_link); + scm_c_define_gsubr + ("dynamic-object?", 1, 0, 0, (scm_t_subr) scm_dynamic_object_p); + scm_c_define_gsubr + ("dynamic-func", 2, 0, 0, (scm_t_subr) scm_dynamic_func); + scm_c_define_gsubr + ("dynamic-pointer", 2, 0, 0, (scm_t_subr) scm_dynamic_pointer); + scm_c_define_gsubr + ("dynamic-call", 2, 0, 0, (scm_t_subr) scm_dynamic_call); +} diff --git a/libguile/dynl.h b/libguile/dynl.h index 3178c9a75..dd10bf42a 100644 --- a/libguile/dynl.h +++ b/libguile/dynl.h @@ -1,7 +1,7 @@ #ifndef SCM_DYNL_H #define SCM_DYNL_H -/* Copyright 1996,1998,2000-2001,2006,2008,2010,2018 +/* Copyright 1996,1998,2000-2001,2006,2008,2010,2018,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -27,11 +27,10 @@ SCM_API SCM scm_dynamic_link (SCM fname); -SCM_API SCM scm_dynamic_unlink (SCM dobj); SCM_API SCM scm_dynamic_object_p (SCM obj); -SCM_API SCM scm_dynamic_pointer (SCM name, SCM dobj); -SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj); -SCM_API SCM scm_dynamic_call (SCM symb, SCM dobj); +SCM_API SCM scm_dynamic_pointer (SCM name, SCM obj); +SCM_API SCM scm_dynamic_func (SCM name, SCM obj); +SCM_API SCM scm_dynamic_call (SCM name, SCM obj); SCM_INTERNAL void scm_init_dynamic_linking (void); diff --git a/libguile/extensions.c b/libguile/extensions.c index a094159d4..61c975e16 100644 --- a/libguile/extensions.c +++ b/libguile/extensions.c @@ -1,4 +1,4 @@ -/* Copyright 2001,2002,2004,2006,2009-2011,2018-2019 +/* Copyright 2001,2002,2004,2006,2009-2011,2018-2019,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -27,6 +27,7 @@ #include "dynwind.h" #include "gc.h" #include "gsubr.h" +#include "foreign.h" #include "strings.h" #include "threads.h" @@ -113,7 +114,9 @@ load_extension (SCM lib, SCM init) /* Dynamically link the library. */ #if HAVE_MODULES - scm_dynamic_call (init, scm_dynamic_link (lib)); + SCM pointer = scm_dynamic_pointer (init, scm_dynamic_link (lib)); + void (*f)(void) = scm_to_pointer (pointer); + f (); #else scm_misc_error ("load-extension", "extension ~S:~S not registered and dynamic-link disabled", diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index a3c732039..44b401fbc 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -1,4 +1,4 @@ -/* Copyright 2003-2013,2018,2020 +/* Copyright 2003-2013,2018,2020,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -206,7 +206,6 @@ main (int argc, char *argv[]) pf ("#define SCM_HAVE_WINSOCK2_H 0 /* 0 or 1 */\n"); #endif - /*** GUILE_DEBUG (defined or undefined) ***/ pf ("\n"); pf ("/* Define to include various undocumented debugging functions. */\n"); @@ -378,6 +377,14 @@ main (int argc, char *argv[]) pf ("/* Define to 1 if there is an auxiliary stack, as in ia64. */\n"); pf ("#define SCM_HAVE_AUXILIARY_STACK %d\n", SCM_I_GSC_HAVE_AUXILIARY_STACK); + pf ("\n"); + pf ("/* Define to 1 to use mini GMP. */\n"); +#if SCM_I_GSC_ENABLE_MINI_GMP == 1 + pf ("#define SCM_ENABLE_MINI_GMP 1\n"); +#else + pf ("#undef SCM_ENABLE_MINI_GMP\n"); +#endif + printf ("#endif\n"); return 0; diff --git a/libguile/gen-scmconfig.h.in b/libguile/gen-scmconfig.h.in index 6e5ebdb84..5b688b338 100644 --- a/libguile/gen-scmconfig.h.in +++ b/libguile/gen-scmconfig.h.in @@ -20,7 +20,7 @@ #define SCM_I_GSC_ICONVEH_QUESTION_MARK @SCM_I_GSC_ICONVEH_QUESTION_MARK@ #define SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE @SCM_I_GSC_ICONVEH_ESCAPE_SEQUENCE@ #define SCM_I_GSC_HAVE_AUXILIARY_STACK @SCM_I_GSC_HAVE_AUXILIARY_STACK@ - +#define SCM_I_GSC_ENABLE_MINI_GMP @SCM_I_GSC_ENABLE_MINI_GMP@ /* Local Variables: mode: c diff --git a/libguile/guile.c b/libguile/guile.c index ae592ed22..bafe5d66e 100644 --- a/libguile/guile.c +++ b/libguile/guile.c @@ -1,4 +1,4 @@ -/* Copyright 1996-1997,2000-2001,2006,2008,2011,2013,2018 +/* Copyright 1996-1997,2000-2001,2006,2008,2011,2013,2018,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -28,7 +28,6 @@ # include <config.h> #endif -#include <ltdl.h> #include <locale.h> #include <stdio.h> diff --git a/libguile/init.c b/libguile/init.c index 2429b2c1a..beffc2c7a 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -31,7 +31,13 @@ #include <sys/stat.h> #include <unistd.h> +#include "scm.h" + +#if SCM_ENABLE_MINI_GMP +#include "mini-gmp.h" +#else #include <gmp.h> +#endif /* Everybody has an init function. */ #include "alist.h" diff --git a/libguile/mini-gmp.c b/libguile/mini-gmp.c new file mode 100644 index 000000000..48ce1072b --- /dev/null +++ b/libguile/mini-gmp.c @@ -0,0 +1,4573 @@ +/* mini-gmp, a minimalistic implementation of a GNU GMP subset. + + Contributed to the GNU project by Niels Möller + +Copyright 1991-1997, 1999-2019 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of either: + + * the GNU Lesser General Public License as published by the Free + Software Foundation; either version 3 of the License, or (at your + option) any later version. + +or + + * the GNU General Public License as published by the Free Software + Foundation; either version 2 of the License, or (at your option) any + later version. + +or both in parallel, as here. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received copies of the GNU General Public License and the +GNU Lesser General Public License along with the GNU MP Library. If not, +see https://www.gnu.org/licenses/. */ + +/* NOTE: All functions in this file which are not declared in + mini-gmp.h are internal, and are not intended to be compatible + with GMP or with future versions of mini-gmp. */ + +/* Much of the material copied from GMP files, including: gmp-impl.h, + longlong.h, mpn/generic/add_n.c, mpn/generic/addmul_1.c, + mpn/generic/lshift.c, mpn/generic/mul_1.c, + mpn/generic/mul_basecase.c, mpn/generic/rshift.c, + mpn/generic/sbpi1_div_qr.c, mpn/generic/sub_n.c, + mpn/generic/submul_1.c. */ + +#include <assert.h> +#include <ctype.h> +#include <limits.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> + +#include "mini-gmp.h" + +#if !defined(MINI_GMP_DONT_USE_FLOAT_H) +#include <float.h> +#endif + + +/* Macros */ +#define GMP_LIMB_BITS (sizeof(mp_limb_t) * CHAR_BIT) + +#define GMP_LIMB_MAX ((mp_limb_t) ~ (mp_limb_t) 0) +#define GMP_LIMB_HIGHBIT ((mp_limb_t) 1 << (GMP_LIMB_BITS - 1)) + +#define GMP_HLIMB_BIT ((mp_limb_t) 1 << (GMP_LIMB_BITS / 2)) +#define GMP_LLIMB_MASK (GMP_HLIMB_BIT - 1) + +#define GMP_ULONG_BITS (sizeof(unsigned long) * CHAR_BIT) +#define GMP_ULONG_HIGHBIT ((unsigned long) 1 << (GMP_ULONG_BITS - 1)) + +#define GMP_ABS(x) ((x) >= 0 ? (x) : -(x)) +#define GMP_NEG_CAST(T,x) (-((T)((x) + 1) - 1)) + +#define GMP_MIN(a, b) ((a) < (b) ? (a) : (b)) +#define GMP_MAX(a, b) ((a) > (b) ? (a) : (b)) + +#define GMP_CMP(a,b) (((a) > (b)) - ((a) < (b))) + +#if defined(DBL_MANT_DIG) && FLT_RADIX == 2 +#define GMP_DBL_MANT_BITS DBL_MANT_DIG +#else +#define GMP_DBL_MANT_BITS (53) +#endif + +/* Return non-zero if xp,xsize and yp,ysize overlap. + If xp+xsize<=yp there's no overlap, or if yp+ysize<=xp there's no + overlap. If both these are false, there's an overlap. */ +#define GMP_MPN_OVERLAP_P(xp, xsize, yp, ysize) \ + ((xp) + (xsize) > (yp) && (yp) + (ysize) > (xp)) + +#define gmp_assert_nocarry(x) do { \ + mp_limb_t __cy = (x); \ + assert (__cy == 0); \ + } while (0) + +#define gmp_clz(count, x) do { \ + mp_limb_t __clz_x = (x); \ + unsigned __clz_c = 0; \ + int LOCAL_SHIFT_BITS = 8; \ + if (GMP_LIMB_BITS > LOCAL_SHIFT_BITS) \ + for (; \ + (__clz_x & ((mp_limb_t) 0xff << (GMP_LIMB_BITS - 8))) == 0; \ + __clz_c += 8) \ + { __clz_x <<= LOCAL_SHIFT_BITS; } \ + for (; (__clz_x & GMP_LIMB_HIGHBIT) == 0; __clz_c++) \ + __clz_x <<= 1; \ + (count) = __clz_c; \ + } while (0) + +#define gmp_ctz(count, x) do { \ + mp_limb_t __ctz_x = (x); \ + unsigned __ctz_c = 0; \ + gmp_clz (__ctz_c, __ctz_x & - __ctz_x); \ + (count) = GMP_LIMB_BITS - 1 - __ctz_c; \ + } while (0) + +#define gmp_add_ssaaaa(sh, sl, ah, al, bh, bl) \ + do { \ + mp_limb_t __x; \ + __x = (al) + (bl); \ + (sh) = (ah) + (bh) + (__x < (al)); \ + (sl) = __x; \ + } while (0) + +#define gmp_sub_ddmmss(sh, sl, ah, al, bh, bl) \ + do { \ + mp_limb_t __x; \ + __x = (al) - (bl); \ + (sh) = (ah) - (bh) - ((al) < (bl)); \ + (sl) = __x; \ + } while (0) + +#define gmp_umul_ppmm(w1, w0, u, v) \ + do { \ + int LOCAL_GMP_LIMB_BITS = GMP_LIMB_BITS; \ + if (sizeof(unsigned int) * CHAR_BIT >= 2 * GMP_LIMB_BITS) \ + { \ + unsigned int __ww = (unsigned int) (u) * (v); \ + w0 = (mp_limb_t) __ww; \ + w1 = (mp_limb_t) (__ww >> LOCAL_GMP_LIMB_BITS); \ + } \ + else if (GMP_ULONG_BITS >= 2 * GMP_LIMB_BITS) \ + { \ + unsigned long int __ww = (unsigned long int) (u) * (v); \ + w0 = (mp_limb_t) __ww; \ + w1 = (mp_limb_t) (__ww >> LOCAL_GMP_LIMB_BITS); \ + } \ + else { \ + mp_limb_t __x0, __x1, __x2, __x3; \ + unsigned __ul, __vl, __uh, __vh; \ + mp_limb_t __u = (u), __v = (v); \ + \ + __ul = __u & GMP_LLIMB_MASK; \ + __uh = __u >> (GMP_LIMB_BITS / 2); \ + __vl = __v & GMP_LLIMB_MASK; \ + __vh = __v >> (GMP_LIMB_BITS / 2); \ + \ + __x0 = (mp_limb_t) __ul * __vl; \ + __x1 = (mp_limb_t) __ul * __vh; \ + __x2 = (mp_limb_t) __uh * __vl; \ + __x3 = (mp_limb_t) __uh * __vh; \ + \ + __x1 += __x0 >> (GMP_LIMB_BITS / 2);/* this can't give carry */ \ + __x1 += __x2; /* but this indeed can */ \ + if (__x1 < __x2) /* did we get it? */ \ + __x3 += GMP_HLIMB_BIT; /* yes, add it in the proper pos. */ \ + \ + (w1) = __x3 + (__x1 >> (GMP_LIMB_BITS / 2)); \ + (w0) = (__x1 << (GMP_LIMB_BITS / 2)) + (__x0 & GMP_LLIMB_MASK); \ + } \ + } while (0) + +#define gmp_udiv_qrnnd_preinv(q, r, nh, nl, d, di) \ + do { \ + mp_limb_t _qh, _ql, _r, _mask; \ + gmp_umul_ppmm (_qh, _ql, (nh), (di)); \ + gmp_add_ssaaaa (_qh, _ql, _qh, _ql, (nh) + 1, (nl)); \ + _r = (nl) - _qh * (d); \ + _mask = -(mp_limb_t) (_r > _ql); /* both > and >= are OK */ \ + _qh += _mask; \ + _r += _mask & (d); \ + if (_r >= (d)) \ + { \ + _r -= (d); \ + _qh++; \ + } \ + \ + (r) = _r; \ + (q) = _qh; \ + } while (0) + +#define gmp_udiv_qr_3by2(q, r1, r0, n2, n1, n0, d1, d0, dinv) \ + do { \ + mp_limb_t _q0, _t1, _t0, _mask; \ + gmp_umul_ppmm ((q), _q0, (n2), (dinv)); \ + gmp_add_ssaaaa ((q), _q0, (q), _q0, (n2), (n1)); \ + \ + /* Compute the two most significant limbs of n - q'd */ \ + (r1) = (n1) - (d1) * (q); \ + gmp_sub_ddmmss ((r1), (r0), (r1), (n0), (d1), (d0)); \ + gmp_umul_ppmm (_t1, _t0, (d0), (q)); \ + gmp_sub_ddmmss ((r1), (r0), (r1), (r0), _t1, _t0); \ + (q)++; \ + \ + /* Conditionally adjust q and the remainders */ \ + _mask = - (mp_limb_t) ((r1) >= _q0); \ + (q) += _mask; \ + gmp_add_ssaaaa ((r1), (r0), (r1), (r0), _mask & (d1), _mask & (d0)); \ + if ((r1) >= (d1)) \ + { \ + if ((r1) > (d1) || (r0) >= (d0)) \ + { \ + (q)++; \ + gmp_sub_ddmmss ((r1), (r0), (r1), (r0), (d1), (d0)); \ + } \ + } \ + } while (0) + +/* Swap macros. */ +#define MP_LIMB_T_SWAP(x, y) \ + do { \ + mp_limb_t __mp_limb_t_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_limb_t_swap__tmp; \ + } while (0) +#define MP_SIZE_T_SWAP(x, y) \ + do { \ + mp_size_t __mp_size_t_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_size_t_swap__tmp; \ + } while (0) +#define MP_BITCNT_T_SWAP(x,y) \ + do { \ + mp_bitcnt_t __mp_bitcnt_t_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_bitcnt_t_swap__tmp; \ + } while (0) +#define MP_PTR_SWAP(x, y) \ + do { \ + mp_ptr __mp_ptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_ptr_swap__tmp; \ + } while (0) +#define MP_SRCPTR_SWAP(x, y) \ + do { \ + mp_srcptr __mp_srcptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mp_srcptr_swap__tmp; \ + } while (0) + +#define MPN_PTR_SWAP(xp,xs, yp,ys) \ + do { \ + MP_PTR_SWAP (xp, yp); \ + MP_SIZE_T_SWAP (xs, ys); \ + } while(0) +#define MPN_SRCPTR_SWAP(xp,xs, yp,ys) \ + do { \ + MP_SRCPTR_SWAP (xp, yp); \ + MP_SIZE_T_SWAP (xs, ys); \ + } while(0) + +#define MPZ_PTR_SWAP(x, y) \ + do { \ + mpz_ptr __mpz_ptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mpz_ptr_swap__tmp; \ + } while (0) +#define MPZ_SRCPTR_SWAP(x, y) \ + do { \ + mpz_srcptr __mpz_srcptr_swap__tmp = (x); \ + (x) = (y); \ + (y) = __mpz_srcptr_swap__tmp; \ + } while (0) + +const int mp_bits_per_limb = GMP_LIMB_BITS; + + +/* Memory allocation and other helper functions. */ +static void +gmp_die (const char *msg) +{ + fprintf (stderr, "%s\n", msg); + abort(); +} + +static void * +gmp_default_alloc (size_t size) +{ + void *p; + + assert (size > 0); + + p = malloc (size); + if (!p) + gmp_die("gmp_default_alloc: Virtual memory exhausted."); + + return p; +} + +static void * +gmp_default_realloc (void *old, size_t unused_old_size, size_t new_size) +{ + void * p; + + p = realloc (old, new_size); + + if (!p) + gmp_die("gmp_default_realloc: Virtual memory exhausted."); + + return p; +} + +static void +gmp_default_free (void *p, size_t unused_size) +{ + free (p); +} + +static void * (*gmp_allocate_func) (size_t) = gmp_default_alloc; +static void * (*gmp_reallocate_func) (void *, size_t, size_t) = gmp_default_realloc; +static void (*gmp_free_func) (void *, size_t) = gmp_default_free; + +void +mp_get_memory_functions (void *(**alloc_func) (size_t), + void *(**realloc_func) (void *, size_t, size_t), + void (**free_func) (void *, size_t)) +{ + if (alloc_func) + *alloc_func = gmp_allocate_func; + + if (realloc_func) + *realloc_func = gmp_reallocate_func; + + if (free_func) + *free_func = gmp_free_func; +} + +void +mp_set_memory_functions (void *(*alloc_func) (size_t), + void *(*realloc_func) (void *, size_t, size_t), + void (*free_func) (void *, size_t)) +{ + if (!alloc_func) + alloc_func = gmp_default_alloc; + if (!realloc_func) + realloc_func = gmp_default_realloc; + if (!free_func) + free_func = gmp_default_free; + + gmp_allocate_func = alloc_func; + gmp_reallocate_func = realloc_func; + gmp_free_func = free_func; +} + +#define gmp_xalloc(size) ((*gmp_allocate_func)((size))) +#define gmp_free(p) ((*gmp_free_func) ((p), 0)) + +static mp_ptr +gmp_xalloc_limbs (mp_size_t size) +{ + return (mp_ptr) gmp_xalloc (size * sizeof (mp_limb_t)); +} + +static mp_ptr +gmp_xrealloc_limbs (mp_ptr old, mp_size_t size) +{ + assert (size > 0); + return (mp_ptr) (*gmp_reallocate_func) (old, 0, size * sizeof (mp_limb_t)); +} + + +/* MPN interface */ + +void +mpn_copyi (mp_ptr d, mp_srcptr s, mp_size_t n) +{ + mp_size_t i; + for (i = 0; i < n; i++) + d[i] = s[i]; +} + +void +mpn_copyd (mp_ptr d, mp_srcptr s, mp_size_t n) +{ + while (--n >= 0) + d[n] = s[n]; +} + +int +mpn_cmp (mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + while (--n >= 0) + { + if (ap[n] != bp[n]) + return ap[n] > bp[n] ? 1 : -1; + } + return 0; +} + +static int +mpn_cmp4 (mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) +{ + if (an != bn) + return an < bn ? -1 : 1; + else + return mpn_cmp (ap, bp, an); +} + +static mp_size_t +mpn_normalized_size (mp_srcptr xp, mp_size_t n) +{ + while (n > 0 && xp[n-1] == 0) + --n; + return n; +} + +int +mpn_zero_p(mp_srcptr rp, mp_size_t n) +{ + return mpn_normalized_size (rp, n) == 0; +} + +void +mpn_zero (mp_ptr rp, mp_size_t n) +{ + while (--n >= 0) + rp[n] = 0; +} + +mp_limb_t +mpn_add_1 (mp_ptr rp, mp_srcptr ap, mp_size_t n, mp_limb_t b) +{ + mp_size_t i; + + assert (n > 0); + i = 0; + do + { + mp_limb_t r = ap[i] + b; + /* Carry out */ + b = (r < b); + rp[i] = r; + } + while (++i < n); + + return b; +} + +mp_limb_t +mpn_add_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + mp_size_t i; + mp_limb_t cy; + + for (i = 0, cy = 0; i < n; i++) + { + mp_limb_t a, b, r; + a = ap[i]; b = bp[i]; + r = a + cy; + cy = (r < cy); + r += b; + cy += (r < b); + rp[i] = r; + } + return cy; +} + +mp_limb_t +mpn_add (mp_ptr rp, mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) +{ + mp_limb_t cy; + + assert (an >= bn); + + cy = mpn_add_n (rp, ap, bp, bn); + if (an > bn) + cy = mpn_add_1 (rp + bn, ap + bn, an - bn, cy); + return cy; +} + +mp_limb_t +mpn_sub_1 (mp_ptr rp, mp_srcptr ap, mp_size_t n, mp_limb_t b) +{ + mp_size_t i; + + assert (n > 0); + + i = 0; + do + { + mp_limb_t a = ap[i]; + /* Carry out */ + mp_limb_t cy = a < b; + rp[i] = a - b; + b = cy; + } + while (++i < n); + + return b; +} + +mp_limb_t +mpn_sub_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + mp_size_t i; + mp_limb_t cy; + + for (i = 0, cy = 0; i < n; i++) + { + mp_limb_t a, b; + a = ap[i]; b = bp[i]; + b += cy; + cy = (b < cy); + cy += (a < b); + rp[i] = a - b; + } + return cy; +} + +mp_limb_t +mpn_sub (mp_ptr rp, mp_srcptr ap, mp_size_t an, mp_srcptr bp, mp_size_t bn) +{ + mp_limb_t cy; + + assert (an >= bn); + + cy = mpn_sub_n (rp, ap, bp, bn); + if (an > bn) + cy = mpn_sub_1 (rp + bn, ap + bn, an - bn, cy); + return cy; +} + +mp_limb_t +mpn_mul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) +{ + mp_limb_t ul, cl, hpl, lpl; + + assert (n >= 1); + + cl = 0; + do + { + ul = *up++; + gmp_umul_ppmm (hpl, lpl, ul, vl); + + lpl += cl; + cl = (lpl < cl) + hpl; + + *rp++ = lpl; + } + while (--n != 0); + + return cl; +} + +mp_limb_t +mpn_addmul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) +{ + mp_limb_t ul, cl, hpl, lpl, rl; + + assert (n >= 1); + + cl = 0; + do + { + ul = *up++; + gmp_umul_ppmm (hpl, lpl, ul, vl); + + lpl += cl; + cl = (lpl < cl) + hpl; + + rl = *rp; + lpl = rl + lpl; + cl += lpl < rl; + *rp++ = lpl; + } + while (--n != 0); + + return cl; +} + +mp_limb_t +mpn_submul_1 (mp_ptr rp, mp_srcptr up, mp_size_t n, mp_limb_t vl) +{ + mp_limb_t ul, cl, hpl, lpl, rl; + + assert (n >= 1); + + cl = 0; + do + { + ul = *up++; + gmp_umul_ppmm (hpl, lpl, ul, vl); + + lpl += cl; + cl = (lpl < cl) + hpl; + + rl = *rp; + lpl = rl - lpl; + cl += lpl > rl; + *rp++ = lpl; + } + while (--n != 0); + + return cl; +} + +mp_limb_t +mpn_mul (mp_ptr rp, mp_srcptr up, mp_size_t un, mp_srcptr vp, mp_size_t vn) +{ + assert (un >= vn); + assert (vn >= 1); + assert (!GMP_MPN_OVERLAP_P(rp, un + vn, up, un)); + assert (!GMP_MPN_OVERLAP_P(rp, un + vn, vp, vn)); + + /* We first multiply by the low order limb. This result can be + stored, not added, to rp. We also avoid a loop for zeroing this + way. */ + + rp[un] = mpn_mul_1 (rp, up, un, vp[0]); + + /* Now accumulate the product of up[] and the next higher limb from + vp[]. */ + + while (--vn >= 1) + { + rp += 1, vp += 1; + rp[un] = mpn_addmul_1 (rp, up, un, vp[0]); + } + return rp[un]; +} + +void +mpn_mul_n (mp_ptr rp, mp_srcptr ap, mp_srcptr bp, mp_size_t n) +{ + mpn_mul (rp, ap, n, bp, n); +} + +void +mpn_sqr (mp_ptr rp, mp_srcptr ap, mp_size_t n) +{ + mpn_mul (rp, ap, n, ap, n); +} + +mp_limb_t +mpn_lshift (mp_ptr rp, mp_srcptr up, mp_size_t n, unsigned int cnt) +{ + mp_limb_t high_limb, low_limb; + unsigned int tnc; + mp_limb_t retval; + + assert (n >= 1); + assert (cnt >= 1); + assert (cnt < GMP_LIMB_BITS); + + up += n; + rp += n; + + tnc = GMP_LIMB_BITS - cnt; + low_limb = *--up; + retval = low_limb >> tnc; + high_limb = (low_limb << cnt); + + while (--n != 0) + { + low_limb = *--up; + *--rp = high_limb | (low_limb >> tnc); + high_limb = (low_limb << cnt); + } + *--rp = high_limb; + + return retval; +} + +mp_limb_t +mpn_rshift (mp_ptr rp, mp_srcptr up, mp_size_t n, unsigned int cnt) +{ + mp_limb_t high_limb, low_limb; + unsigned int tnc; + mp_limb_t retval; + + assert (n >= 1); + assert (cnt >= 1); + assert (cnt < GMP_LIMB_BITS); + + tnc = GMP_LIMB_BITS - cnt; + high_limb = *up++; + retval = (high_limb << tnc); + low_limb = high_limb >> cnt; + + while (--n != 0) + { + high_limb = *up++; + *rp++ = low_limb | (high_limb << tnc); + low_limb = high_limb >> cnt; + } + *rp = low_limb; + + return retval; +} + +static mp_bitcnt_t +mpn_common_scan (mp_limb_t limb, mp_size_t i, mp_srcptr up, mp_size_t un, + mp_limb_t ux) +{ + unsigned cnt; + + assert (ux == 0 || ux == GMP_LIMB_MAX); + assert (0 <= i && i <= un ); + + while (limb == 0) + { + i++; + if (i == un) + return (ux == 0 ? ~(mp_bitcnt_t) 0 : un * GMP_LIMB_BITS); + limb = ux ^ up[i]; + } + gmp_ctz (cnt, limb); + return (mp_bitcnt_t) i * GMP_LIMB_BITS + cnt; +} + +mp_bitcnt_t +mpn_scan1 (mp_srcptr ptr, mp_bitcnt_t bit) +{ + mp_size_t i; + i = bit / GMP_LIMB_BITS; + + return mpn_common_scan ( ptr[i] & (GMP_LIMB_MAX << (bit % GMP_LIMB_BITS)), + i, ptr, i, 0); +} + +mp_bitcnt_t +mpn_scan0 (mp_srcptr ptr, mp_bitcnt_t bit) +{ + mp_size_t i; + i = bit / GMP_LIMB_BITS; + + return mpn_common_scan (~ptr[i] & (GMP_LIMB_MAX << (bit % GMP_LIMB_BITS)), + i, ptr, i, GMP_LIMB_MAX); +} + +void +mpn_com (mp_ptr rp, mp_srcptr up, mp_size_t n) +{ + while (--n >= 0) + *rp++ = ~ *up++; +} + +mp_limb_t +mpn_neg (mp_ptr rp, mp_srcptr up, mp_size_t n) +{ + while (*up == 0) + { + *rp = 0; + if (!--n) + return 0; + ++up; ++rp; + } + *rp = - *up; + mpn_com (++rp, ++up, --n); + return 1; +} + + +/* MPN division interface. */ + +/* The 3/2 inverse is defined as + + m = floor( (B^3-1) / (B u1 + u0)) - B +*/ +mp_limb_t +mpn_invert_3by2 (mp_limb_t u1, mp_limb_t u0) +{ + mp_limb_t r, m; + + { + mp_limb_t p, ql; + unsigned ul, uh, qh; + + /* For notation, let b denote the half-limb base, so that B = b^2. + Split u1 = b uh + ul. */ + ul = u1 & GMP_LLIMB_MASK; + uh = u1 >> (GMP_LIMB_BITS / 2); + + /* Approximation of the high half of quotient. Differs from the 2/1 + inverse of the half limb uh, since we have already subtracted + u0. */ + qh = (u1 ^ GMP_LIMB_MAX) / uh; + + /* Adjust to get a half-limb 3/2 inverse, i.e., we want + + qh' = floor( (b^3 - 1) / u) - b = floor ((b^3 - b u - 1) / u + = floor( (b (~u) + b-1) / u), + + and the remainder + + r = b (~u) + b-1 - qh (b uh + ul) + = b (~u - qh uh) + b-1 - qh ul + + Subtraction of qh ul may underflow, which implies adjustments. + But by normalization, 2 u >= B > qh ul, so we need to adjust by + at most 2. + */ + + r = ((~u1 - (mp_limb_t) qh * uh) << (GMP_LIMB_BITS / 2)) | GMP_LLIMB_MASK; + + p = (mp_limb_t) qh * ul; + /* Adjustment steps taken from udiv_qrnnd_c */ + if (r < p) + { + qh--; + r += u1; + if (r >= u1) /* i.e. we didn't get carry when adding to r */ + if (r < p) + { + qh--; + r += u1; + } + } + r -= p; + + /* Low half of the quotient is + + ql = floor ( (b r + b-1) / u1). + + This is a 3/2 division (on half-limbs), for which qh is a + suitable inverse. */ + + p = (r >> (GMP_LIMB_BITS / 2)) * qh + r; + /* Unlike full-limb 3/2, we can add 1 without overflow. For this to + work, it is essential that ql is a full mp_limb_t. */ + ql = (p >> (GMP_LIMB_BITS / 2)) + 1; + + /* By the 3/2 trick, we don't need the high half limb. */ + r = (r << (GMP_LIMB_BITS / 2)) + GMP_LLIMB_MASK - ql * u1; + + if (r >= (GMP_LIMB_MAX & (p << (GMP_LIMB_BITS / 2)))) + { + ql--; + r += u1; + } + m = ((mp_limb_t) qh << (GMP_LIMB_BITS / 2)) + ql; + if (r >= u1) + { + m++; + r -= u1; + } + } + + /* Now m is the 2/1 inverse of u1. If u0 > 0, adjust it to become a + 3/2 inverse. */ + if (u0 > 0) + { + mp_limb_t th, tl; + r = ~r; + r += u0; + if (r < u0) + { + m--; + if (r >= u1) + { + m--; + r -= u1; + } + r -= u1; + } + gmp_umul_ppmm (th, tl, u0, m); + r += th; + if (r < th) + { + m--; + m -= ((r > u1) | ((r == u1) & (tl > u0))); + } + } + + return m; +} + +struct gmp_div_inverse +{ + /* Normalization shift count. */ + unsigned shift; + /* Normalized divisor (d0 unused for mpn_div_qr_1) */ + mp_limb_t d1, d0; + /* Inverse, for 2/1 or 3/2. */ + mp_limb_t di; +}; + +static void +mpn_div_qr_1_invert (struct gmp_div_inverse *inv, mp_limb_t d) +{ + unsigned shift; + + assert (d > 0); + gmp_clz (shift, d); + inv->shift = shift; + inv->d1 = d << shift; + inv->di = mpn_invert_limb (inv->d1); +} + +static void +mpn_div_qr_2_invert (struct gmp_div_inverse *inv, + mp_limb_t d1, mp_limb_t d0) +{ + unsigned shift; + + assert (d1 > 0); + gmp_clz (shift, d1); + inv->shift = shift; + if (shift > 0) + { + d1 = (d1 << shift) | (d0 >> (GMP_LIMB_BITS - shift)); + d0 <<= shift; + } + inv->d1 = d1; + inv->d0 = d0; + inv->di = mpn_invert_3by2 (d1, d0); +} + +static void +mpn_div_qr_invert (struct gmp_div_inverse *inv, + mp_srcptr dp, mp_size_t dn) +{ + assert (dn > 0); + + if (dn == 1) + mpn_div_qr_1_invert (inv, dp[0]); + else if (dn == 2) + mpn_div_qr_2_invert (inv, dp[1], dp[0]); + else + { + unsigned shift; + mp_limb_t d1, d0; + + d1 = dp[dn-1]; + d0 = dp[dn-2]; + assert (d1 > 0); + gmp_clz (shift, d1); + inv->shift = shift; + if (shift > 0) + { + d1 = (d1 << shift) | (d0 >> (GMP_LIMB_BITS - shift)); + d0 = (d0 << shift) | (dp[dn-3] >> (GMP_LIMB_BITS - shift)); + } + inv->d1 = d1; + inv->d0 = d0; + inv->di = mpn_invert_3by2 (d1, d0); + } +} + +/* Not matching current public gmp interface, rather corresponding to + the sbpi1_div_* functions. */ +static mp_limb_t +mpn_div_qr_1_preinv (mp_ptr qp, mp_srcptr np, mp_size_t nn, + const struct gmp_div_inverse *inv) +{ + mp_limb_t d, di; + mp_limb_t r; + mp_ptr tp = NULL; + + if (inv->shift > 0) + { + /* Shift, reusing qp area if possible. In-place shift if qp == np. */ + tp = qp ? qp : gmp_xalloc_limbs (nn); + r = mpn_lshift (tp, np, nn, inv->shift); + np = tp; + } + else + r = 0; + + d = inv->d1; + di = inv->di; + while (--nn >= 0) + { + mp_limb_t q; + + gmp_udiv_qrnnd_preinv (q, r, r, np[nn], d, di); + if (qp) + qp[nn] = q; + } + if ((inv->shift > 0) && (tp != qp)) + gmp_free (tp); + + return r >> inv->shift; +} + +static void +mpn_div_qr_2_preinv (mp_ptr qp, mp_ptr np, mp_size_t nn, + const struct gmp_div_inverse *inv) +{ + unsigned shift; + mp_size_t i; + mp_limb_t d1, d0, di, r1, r0; + + assert (nn >= 2); + shift = inv->shift; + d1 = inv->d1; + d0 = inv->d0; + di = inv->di; + + if (shift > 0) + r1 = mpn_lshift (np, np, nn, shift); + else + r1 = 0; + + r0 = np[nn - 1]; + + i = nn - 2; + do + { + mp_limb_t n0, q; + n0 = np[i]; + gmp_udiv_qr_3by2 (q, r1, r0, r1, r0, n0, d1, d0, di); + + if (qp) + qp[i] = q; + } + while (--i >= 0); + + if (shift > 0) + { + assert ((r0 & (GMP_LIMB_MAX >> (GMP_LIMB_BITS - shift))) == 0); + r0 = (r0 >> shift) | (r1 << (GMP_LIMB_BITS - shift)); + r1 >>= shift; + } + + np[1] = r1; + np[0] = r0; +} + +static void +mpn_div_qr_pi1 (mp_ptr qp, + mp_ptr np, mp_size_t nn, mp_limb_t n1, + mp_srcptr dp, mp_size_t dn, + mp_limb_t dinv) +{ + mp_size_t i; + + mp_limb_t d1, d0; + mp_limb_t cy, cy1; + mp_limb_t q; + + assert (dn > 2); + assert (nn >= dn); + + d1 = dp[dn - 1]; + d0 = dp[dn - 2]; + + assert ((d1 & GMP_LIMB_HIGHBIT) != 0); + /* Iteration variable is the index of the q limb. + * + * We divide <n1, np[dn-1+i], np[dn-2+i], np[dn-3+i],..., np[i]> + * by <d1, d0, dp[dn-3], ..., dp[0] > + */ + + i = nn - dn; + do + { + mp_limb_t n0 = np[dn-1+i]; + + if (n1 == d1 && n0 == d0) + { + q = GMP_LIMB_MAX; + mpn_submul_1 (np+i, dp, dn, q); + n1 = np[dn-1+i]; /* update n1, last loop's value will now be invalid */ + } + else + { + gmp_udiv_qr_3by2 (q, n1, n0, n1, n0, np[dn-2+i], d1, d0, dinv); + + cy = mpn_submul_1 (np + i, dp, dn-2, q); + + cy1 = n0 < cy; + n0 = n0 - cy; + cy = n1 < cy1; + n1 = n1 - cy1; + np[dn-2+i] = n0; + + if (cy != 0) + { + n1 += d1 + mpn_add_n (np + i, np + i, dp, dn - 1); + q--; + } + } + + if (qp) + qp[i] = q; + } + while (--i >= 0); + + np[dn - 1] = n1; +} + +static void +mpn_div_qr_preinv (mp_ptr qp, mp_ptr np, mp_size_t nn, + mp_srcptr dp, mp_size_t dn, + const struct gmp_div_inverse *inv) +{ + assert (dn > 0); + assert (nn >= dn); + + if (dn == 1) + np[0] = mpn_div_qr_1_preinv (qp, np, nn, inv); + else if (dn == 2) + mpn_div_qr_2_preinv (qp, np, nn, inv); + else + { + mp_limb_t nh; + unsigned shift; + + assert (inv->d1 == dp[dn-1]); + assert (inv->d0 == dp[dn-2]); + assert ((inv->d1 & GMP_LIMB_HIGHBIT) != 0); + + shift = inv->shift; + if (shift > 0) + nh = mpn_lshift (np, np, nn, shift); + else + nh = 0; + + mpn_div_qr_pi1 (qp, np, nn, nh, dp, dn, inv->di); + + if (shift > 0) + gmp_assert_nocarry (mpn_rshift (np, np, dn, shift)); + } +} + +static void +mpn_div_qr (mp_ptr qp, mp_ptr np, mp_size_t nn, mp_srcptr dp, mp_size_t dn) +{ + struct gmp_div_inverse inv; + mp_ptr tp = NULL; + + assert (dn > 0); + assert (nn >= dn); + + mpn_div_qr_invert (&inv, dp, dn); + if (dn > 2 && inv.shift > 0) + { + tp = gmp_xalloc_limbs (dn); + gmp_assert_nocarry (mpn_lshift (tp, dp, dn, inv.shift)); + dp = tp; + } + mpn_div_qr_preinv (qp, np, nn, dp, dn, &inv); + if (tp) + gmp_free (tp); +} + + +/* MPN base conversion. */ +static unsigned +mpn_base_power_of_two_p (unsigned b) +{ + switch (b) + { + case 2: return 1; + case 4: return 2; + case 8: return 3; + case 16: return 4; + case 32: return 5; + case 64: return 6; + case 128: return 7; + case 256: return 8; + default: return 0; + } +} + +struct mpn_base_info +{ + /* bb is the largest power of the base which fits in one limb, and + exp is the corresponding exponent. */ + unsigned exp; + mp_limb_t bb; +}; + +static void +mpn_get_base_info (struct mpn_base_info *info, mp_limb_t b) +{ + mp_limb_t m; + mp_limb_t p; + unsigned exp; + + m = GMP_LIMB_MAX / b; + for (exp = 1, p = b; p <= m; exp++) + p *= b; + + info->exp = exp; + info->bb = p; +} + +static mp_bitcnt_t +mpn_limb_size_in_base_2 (mp_limb_t u) +{ + unsigned shift; + + assert (u > 0); + gmp_clz (shift, u); + return GMP_LIMB_BITS - shift; +} + +static size_t +mpn_get_str_bits (unsigned char *sp, unsigned bits, mp_srcptr up, mp_size_t un) +{ + unsigned char mask; + size_t sn, j; + mp_size_t i; + unsigned shift; + + sn = ((un - 1) * GMP_LIMB_BITS + mpn_limb_size_in_base_2 (up[un-1]) + + bits - 1) / bits; + + mask = (1U << bits) - 1; + + for (i = 0, j = sn, shift = 0; j-- > 0;) + { + unsigned char digit = up[i] >> shift; + + shift += bits; + + if (shift >= GMP_LIMB_BITS && ++i < un) + { + shift -= GMP_LIMB_BITS; + digit |= up[i] << (bits - shift); + } + sp[j] = digit & mask; + } + return sn; +} + +/* We generate digits from the least significant end, and reverse at + the end. */ +static size_t +mpn_limb_get_str (unsigned char *sp, mp_limb_t w, + const struct gmp_div_inverse *binv) +{ + mp_size_t i; + for (i = 0; w > 0; i++) + { + mp_limb_t h, l, r; + + h = w >> (GMP_LIMB_BITS - binv->shift); + l = w << binv->shift; + + gmp_udiv_qrnnd_preinv (w, r, h, l, binv->d1, binv->di); + assert ((r & (GMP_LIMB_MAX >> (GMP_LIMB_BITS - binv->shift))) == 0); + r >>= binv->shift; + + sp[i] = r; + } + return i; +} + +static size_t +mpn_get_str_other (unsigned char *sp, + int base, const struct mpn_base_info *info, + mp_ptr up, mp_size_t un) +{ + struct gmp_div_inverse binv; + size_t sn; + size_t i; + + mpn_div_qr_1_invert (&binv, base); + + sn = 0; + + if (un > 1) + { + struct gmp_div_inverse bbinv; + mpn_div_qr_1_invert (&bbinv, info->bb); + + do + { + mp_limb_t w; + size_t done; + w = mpn_div_qr_1_preinv (up, up, un, &bbinv); + un -= (up[un-1] == 0); + done = mpn_limb_get_str (sp + sn, w, &binv); + + for (sn += done; done < info->exp; done++) + sp[sn++] = 0; + } + while (un > 1); + } + sn += mpn_limb_get_str (sp + sn, up[0], &binv); + + /* Reverse order */ + for (i = 0; 2*i + 1 < sn; i++) + { + unsigned char t = sp[i]; + sp[i] = sp[sn - i - 1]; + sp[sn - i - 1] = t; + } + + return sn; +} + +size_t +mpn_get_str (unsigned char *sp, int base, mp_ptr up, mp_size_t un) +{ + unsigned bits; + + assert (un > 0); + assert (up[un-1] > 0); + + bits = mpn_base_power_of_two_p (base); + if (bits) + return mpn_get_str_bits (sp, bits, up, un); + else + { + struct mpn_base_info info; + + mpn_get_base_info (&info, base); + return mpn_get_str_other (sp, base, &info, up, un); + } +} + +static mp_size_t +mpn_set_str_bits (mp_ptr rp, const unsigned char *sp, size_t sn, + unsigned bits) +{ + mp_size_t rn; + size_t j; + unsigned shift; + + for (j = sn, rn = 0, shift = 0; j-- > 0; ) + { + if (shift == 0) + { + rp[rn++] = sp[j]; + shift += bits; + } + else + { + rp[rn-1] |= (mp_limb_t) sp[j] << shift; + shift += bits; + if (shift >= GMP_LIMB_BITS) + { + shift -= GMP_LIMB_BITS; + if (shift > 0) + rp[rn++] = (mp_limb_t) sp[j] >> (bits - shift); + } + } + } + rn = mpn_normalized_size (rp, rn); + return rn; +} + +/* Result is usually normalized, except for all-zero input, in which + case a single zero limb is written at *RP, and 1 is returned. */ +static mp_size_t +mpn_set_str_other (mp_ptr rp, const unsigned char *sp, size_t sn, + mp_limb_t b, const struct mpn_base_info *info) +{ + mp_size_t rn; + mp_limb_t w; + unsigned k; + size_t j; + + assert (sn > 0); + + k = 1 + (sn - 1) % info->exp; + + j = 0; + w = sp[j++]; + while (--k != 0) + w = w * b + sp[j++]; + + rp[0] = w; + + for (rn = 1; j < sn;) + { + mp_limb_t cy; + + w = sp[j++]; + for (k = 1; k < info->exp; k++) + w = w * b + sp[j++]; + + cy = mpn_mul_1 (rp, rp, rn, info->bb); + cy += mpn_add_1 (rp, rp, rn, w); + if (cy > 0) + rp[rn++] = cy; + } + assert (j == sn); + + return rn; +} + +mp_size_t +mpn_set_str (mp_ptr rp, const unsigned char *sp, size_t sn, int base) +{ + unsigned bits; + + if (sn == 0) + return 0; + + bits = mpn_base_power_of_two_p (base); + if (bits) + return mpn_set_str_bits (rp, sp, sn, bits); + else + { + struct mpn_base_info info; + + mpn_get_base_info (&info, base); + return mpn_set_str_other (rp, sp, sn, base, &info); + } +} + + +/* MPZ interface */ +void +mpz_init (mpz_t r) +{ + static const mp_limb_t dummy_limb = GMP_LIMB_MAX & 0xc1a0; + + r->_mp_alloc = 0; + r->_mp_size = 0; + r->_mp_d = (mp_ptr) &dummy_limb; +} + +/* The utility of this function is a bit limited, since many functions + assigns the result variable using mpz_swap. */ +void +mpz_init2 (mpz_t r, mp_bitcnt_t bits) +{ + mp_size_t rn; + + bits -= (bits != 0); /* Round down, except if 0 */ + rn = 1 + bits / GMP_LIMB_BITS; + + r->_mp_alloc = rn; + r->_mp_size = 0; + r->_mp_d = gmp_xalloc_limbs (rn); +} + +void +mpz_clear (mpz_t r) +{ + if (r->_mp_alloc) + gmp_free (r->_mp_d); +} + +static mp_ptr +mpz_realloc (mpz_t r, mp_size_t size) +{ + size = GMP_MAX (size, 1); + + if (r->_mp_alloc) + r->_mp_d = gmp_xrealloc_limbs (r->_mp_d, size); + else + r->_mp_d = gmp_xalloc_limbs (size); + r->_mp_alloc = size; + + if (GMP_ABS (r->_mp_size) > size) + r->_mp_size = 0; + + return r->_mp_d; +} + +/* Realloc for an mpz_t WHAT if it has less than NEEDED limbs. */ +#define MPZ_REALLOC(z,n) ((n) > (z)->_mp_alloc \ + ? mpz_realloc(z,n) \ + : (z)->_mp_d) + +/* MPZ assignment and basic conversions. */ +void +mpz_set_si (mpz_t r, signed long int x) +{ + if (x >= 0) + mpz_set_ui (r, x); + else /* (x < 0) */ + if (GMP_LIMB_BITS < GMP_ULONG_BITS) + { + mpz_set_ui (r, GMP_NEG_CAST (unsigned long int, x)); + mpz_neg (r, r); + } + else + { + r->_mp_size = -1; + MPZ_REALLOC (r, 1)[0] = GMP_NEG_CAST (unsigned long int, x); + } +} + +void +mpz_set_ui (mpz_t r, unsigned long int x) +{ + if (x > 0) + { + r->_mp_size = 1; + MPZ_REALLOC (r, 1)[0] = x; + if (GMP_LIMB_BITS < GMP_ULONG_BITS) + { + int LOCAL_GMP_LIMB_BITS = GMP_LIMB_BITS; + while (x >>= LOCAL_GMP_LIMB_BITS) + { + ++ r->_mp_size; + MPZ_REALLOC (r, r->_mp_size)[r->_mp_size - 1] = x; + } + } + } + else + r->_mp_size = 0; +} + +void +mpz_set (mpz_t r, const mpz_t x) +{ + /* Allow the NOP r == x */ + if (r != x) + { + mp_size_t n; + mp_ptr rp; + + n = GMP_ABS (x->_mp_size); + rp = MPZ_REALLOC (r, n); + + mpn_copyi (rp, x->_mp_d, n); + r->_mp_size = x->_mp_size; + } +} + +void +mpz_init_set_si (mpz_t r, signed long int x) +{ + mpz_init (r); + mpz_set_si (r, x); +} + +void +mpz_init_set_ui (mpz_t r, unsigned long int x) +{ + mpz_init (r); + mpz_set_ui (r, x); +} + +void +mpz_init_set (mpz_t r, const mpz_t x) +{ + mpz_init (r); + mpz_set (r, x); +} + +int +mpz_fits_slong_p (const mpz_t u) +{ + return (LONG_MAX + LONG_MIN == 0 || mpz_cmp_ui (u, LONG_MAX) <= 0) && + mpz_cmpabs_ui (u, GMP_NEG_CAST (unsigned long int, LONG_MIN)) <= 0; +} + +static int +mpn_absfits_ulong_p (mp_srcptr up, mp_size_t un) +{ + int ulongsize = GMP_ULONG_BITS / GMP_LIMB_BITS; + mp_limb_t ulongrem = 0; + + if (GMP_ULONG_BITS % GMP_LIMB_BITS != 0) + ulongrem = (mp_limb_t) (ULONG_MAX >> GMP_LIMB_BITS * ulongsize) + 1; + + return un <= ulongsize || (up[ulongsize] < ulongrem && un == ulongsize + 1); +} + +int +mpz_fits_ulong_p (const mpz_t u) +{ + mp_size_t us = u->_mp_size; + + return us >= 0 && mpn_absfits_ulong_p (u->_mp_d, us); +} + +long int +mpz_get_si (const mpz_t u) +{ + unsigned long r = mpz_get_ui (u); + unsigned long c = -LONG_MAX - LONG_MIN; + + if (u->_mp_size < 0) + /* This expression is necessary to properly handle -LONG_MIN */ + return -(long) c - (long) ((r - c) & LONG_MAX); + else + return (long) (r & LONG_MAX); +} + +unsigned long int +mpz_get_ui (const mpz_t u) +{ + if (GMP_LIMB_BITS < GMP_ULONG_BITS) + { + int LOCAL_GMP_LIMB_BITS = GMP_LIMB_BITS; + unsigned long r = 0; + mp_size_t n = GMP_ABS (u->_mp_size); + n = GMP_MIN (n, 1 + (mp_size_t) (GMP_ULONG_BITS - 1) / GMP_LIMB_BITS); + while (--n >= 0) + r = (r << LOCAL_GMP_LIMB_BITS) + u->_mp_d[n]; + return r; + } + + return u->_mp_size == 0 ? 0 : u->_mp_d[0]; +} + +size_t +mpz_size (const mpz_t u) +{ + return GMP_ABS (u->_mp_size); +} + +mp_limb_t +mpz_getlimbn (const mpz_t u, mp_size_t n) +{ + if (n >= 0 && n < GMP_ABS (u->_mp_size)) + return u->_mp_d[n]; + else + return 0; +} + +void +mpz_realloc2 (mpz_t x, mp_bitcnt_t n) +{ + mpz_realloc (x, 1 + (n - (n != 0)) / GMP_LIMB_BITS); +} + +mp_srcptr +mpz_limbs_read (mpz_srcptr x) +{ + return x->_mp_d; +} + +mp_ptr +mpz_limbs_modify (mpz_t x, mp_size_t n) +{ + assert (n > 0); + return MPZ_REALLOC (x, n); +} + +mp_ptr +mpz_limbs_write (mpz_t x, mp_size_t n) +{ + return mpz_limbs_modify (x, n); +} + +void +mpz_limbs_finish (mpz_t x, mp_size_t xs) +{ + mp_size_t xn; + xn = mpn_normalized_size (x->_mp_d, GMP_ABS (xs)); + x->_mp_size = xs < 0 ? -xn : xn; +} + +static mpz_srcptr +mpz_roinit_normal_n (mpz_t x, mp_srcptr xp, mp_size_t xs) +{ + x->_mp_alloc = 0; + x->_mp_d = (mp_ptr) xp; + x->_mp_size = xs; + return x; +} + +mpz_srcptr +mpz_roinit_n (mpz_t x, mp_srcptr xp, mp_size_t xs) +{ + mpz_roinit_normal_n (x, xp, xs); + mpz_limbs_finish (x, xs); + return x; +} + + +/* Conversions and comparison to double. */ +void +mpz_set_d (mpz_t r, double x) +{ + int sign; + mp_ptr rp; + mp_size_t rn, i; + double B; + double Bi; + mp_limb_t f; + + /* x != x is true when x is a NaN, and x == x * 0.5 is true when x is + zero or infinity. */ + if (x != x || x == x * 0.5) + { + r->_mp_size = 0; + return; + } + + sign = x < 0.0 ; + if (sign) + x = - x; + + if (x < 1.0) + { + r->_mp_size = 0; + return; + } + B = 4.0 * (double) (GMP_LIMB_HIGHBIT >> 1); + Bi = 1.0 / B; + for (rn = 1; x >= B; rn++) + x *= Bi; + + rp = MPZ_REALLOC (r, rn); + + f = (mp_limb_t) x; + x -= f; + assert (x < 1.0); + i = rn-1; + rp[i] = f; + while (--i >= 0) + { + x = B * x; + f = (mp_limb_t) x; + x -= f; + assert (x < 1.0); + rp[i] = f; + } + + r->_mp_size = sign ? - rn : rn; +} + +void +mpz_init_set_d (mpz_t r, double x) +{ + mpz_init (r); + mpz_set_d (r, x); +} + +double +mpz_get_d (const mpz_t u) +{ + int m; + mp_limb_t l; + mp_size_t un; + double x; + double B = 4.0 * (double) (GMP_LIMB_HIGHBIT >> 1); + + un = GMP_ABS (u->_mp_size); + + if (un == 0) + return 0.0; + + l = u->_mp_d[--un]; + gmp_clz (m, l); + m = m + GMP_DBL_MANT_BITS - GMP_LIMB_BITS; + if (m < 0) + l &= GMP_LIMB_MAX << -m; + + for (x = l; --un >= 0;) + { + x = B*x; + if (m > 0) { + l = u->_mp_d[un]; + m -= GMP_LIMB_BITS; + if (m < 0) + l &= GMP_LIMB_MAX << -m; + x += l; + } + } + + if (u->_mp_size < 0) + x = -x; + + return x; +} + +int +mpz_cmpabs_d (const mpz_t x, double d) +{ + mp_size_t xn; + double B, Bi; + mp_size_t i; + + xn = x->_mp_size; + d = GMP_ABS (d); + + if (xn != 0) + { + xn = GMP_ABS (xn); + + B = 4.0 * (double) (GMP_LIMB_HIGHBIT >> 1); + Bi = 1.0 / B; + + /* Scale d so it can be compared with the top limb. */ + for (i = 1; i < xn; i++) + d *= Bi; + + if (d >= B) + return -1; + + /* Compare floor(d) to top limb, subtract and cancel when equal. */ + for (i = xn; i-- > 0;) + { + mp_limb_t f, xl; + + f = (mp_limb_t) d; + xl = x->_mp_d[i]; + if (xl > f) + return 1; + else if (xl < f) + return -1; + d = B * (d - f); + } + } + return - (d > 0.0); +} + +int +mpz_cmp_d (const mpz_t x, double d) +{ + if (x->_mp_size < 0) + { + if (d >= 0.0) + return -1; + else + return -mpz_cmpabs_d (x, d); + } + else + { + if (d < 0.0) + return 1; + else + return mpz_cmpabs_d (x, d); + } +} + + +/* MPZ comparisons and the like. */ +int +mpz_sgn (const mpz_t u) +{ + return GMP_CMP (u->_mp_size, 0); +} + +int +mpz_cmp_si (const mpz_t u, long v) +{ + mp_size_t usize = u->_mp_size; + + if (v >= 0) + return mpz_cmp_ui (u, v); + else if (usize >= 0) + return 1; + else + return - mpz_cmpabs_ui (u, GMP_NEG_CAST (unsigned long int, v)); +} + +int +mpz_cmp_ui (const mpz_t u, unsigned long v) +{ + mp_size_t usize = u->_mp_size; + + if (usize < 0) + return -1; + else + return mpz_cmpabs_ui (u, v); +} + +int +mpz_cmp (const mpz_t a, const mpz_t b) +{ + mp_size_t asize = a->_mp_size; + mp_size_t bsize = b->_mp_size; + + if (asize != bsize) + return (asize < bsize) ? -1 : 1; + else if (asize >= 0) + return mpn_cmp (a->_mp_d, b->_mp_d, asize); + else + return mpn_cmp (b->_mp_d, a->_mp_d, -asize); +} + +int +mpz_cmpabs_ui (const mpz_t u, unsigned long v) +{ + mp_size_t un = GMP_ABS (u->_mp_size); + + if (! mpn_absfits_ulong_p (u->_mp_d, un)) + return 1; + else + { + unsigned long uu = mpz_get_ui (u); + return GMP_CMP(uu, v); + } +} + +int +mpz_cmpabs (const mpz_t u, const mpz_t v) +{ + return mpn_cmp4 (u->_mp_d, GMP_ABS (u->_mp_size), + v->_mp_d, GMP_ABS (v->_mp_size)); +} + +void +mpz_abs (mpz_t r, const mpz_t u) +{ + mpz_set (r, u); + r->_mp_size = GMP_ABS (r->_mp_size); +} + +void +mpz_neg (mpz_t r, const mpz_t u) +{ + mpz_set (r, u); + r->_mp_size = -r->_mp_size; +} + +void +mpz_swap (mpz_t u, mpz_t v) +{ + MP_SIZE_T_SWAP (u->_mp_size, v->_mp_size); + MP_SIZE_T_SWAP (u->_mp_alloc, v->_mp_alloc); + MP_PTR_SWAP (u->_mp_d, v->_mp_d); +} + + +/* MPZ addition and subtraction */ + + +void +mpz_add_ui (mpz_t r, const mpz_t a, unsigned long b) +{ + mpz_t bb; + mpz_init_set_ui (bb, b); + mpz_add (r, a, bb); + mpz_clear (bb); +} + +void +mpz_sub_ui (mpz_t r, const mpz_t a, unsigned long b) +{ + mpz_ui_sub (r, b, a); + mpz_neg (r, r); +} + +void +mpz_ui_sub (mpz_t r, unsigned long a, const mpz_t b) +{ + mpz_neg (r, b); + mpz_add_ui (r, r, a); +} + +static mp_size_t +mpz_abs_add (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t an = GMP_ABS (a->_mp_size); + mp_size_t bn = GMP_ABS (b->_mp_size); + mp_ptr rp; + mp_limb_t cy; + + if (an < bn) + { + MPZ_SRCPTR_SWAP (a, b); + MP_SIZE_T_SWAP (an, bn); + } + + rp = MPZ_REALLOC (r, an + 1); + cy = mpn_add (rp, a->_mp_d, an, b->_mp_d, bn); + + rp[an] = cy; + + return an + cy; +} + +static mp_size_t +mpz_abs_sub (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t an = GMP_ABS (a->_mp_size); + mp_size_t bn = GMP_ABS (b->_mp_size); + int cmp; + mp_ptr rp; + + cmp = mpn_cmp4 (a->_mp_d, an, b->_mp_d, bn); + if (cmp > 0) + { + rp = MPZ_REALLOC (r, an); + gmp_assert_nocarry (mpn_sub (rp, a->_mp_d, an, b->_mp_d, bn)); + return mpn_normalized_size (rp, an); + } + else if (cmp < 0) + { + rp = MPZ_REALLOC (r, bn); + gmp_assert_nocarry (mpn_sub (rp, b->_mp_d, bn, a->_mp_d, an)); + return -mpn_normalized_size (rp, bn); + } + else + return 0; +} + +void +mpz_add (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t rn; + + if ( (a->_mp_size ^ b->_mp_size) >= 0) + rn = mpz_abs_add (r, a, b); + else + rn = mpz_abs_sub (r, a, b); + + r->_mp_size = a->_mp_size >= 0 ? rn : - rn; +} + +void +mpz_sub (mpz_t r, const mpz_t a, const mpz_t b) +{ + mp_size_t rn; + + if ( (a->_mp_size ^ b->_mp_size) >= 0) + rn = mpz_abs_sub (r, a, b); + else + rn = mpz_abs_add (r, a, b); + + r->_mp_size = a->_mp_size >= 0 ? rn : - rn; +} + + +/* MPZ multiplication */ +void +mpz_mul_si (mpz_t r, const mpz_t u, long int v) +{ + if (v < 0) + { + mpz_mul_ui (r, u, GMP_NEG_CAST (unsigned long int, v)); + mpz_neg (r, r); + } + else + mpz_mul_ui (r, u, v); +} + +void +mpz_mul_ui (mpz_t r, const mpz_t u, unsigned long int v) +{ + mpz_t vv; + mpz_init_set_ui (vv, v); + mpz_mul (r, u, vv); + mpz_clear (vv); + return; +} + +void +mpz_mul (mpz_t r, const mpz_t u, const mpz_t v) +{ + int sign; + mp_size_t un, vn, rn; + mpz_t t; + mp_ptr tp; + + un = u->_mp_size; + vn = v->_mp_size; + + if (un == 0 || vn == 0) + { + r->_mp_size = 0; + return; + } + + sign = (un ^ vn) < 0; + + un = GMP_ABS (un); + vn = GMP_ABS (vn); + + mpz_init2 (t, (un + vn) * GMP_LIMB_BITS); + + tp = t->_mp_d; + if (un >= vn) + mpn_mul (tp, u->_mp_d, un, v->_mp_d, vn); + else + mpn_mul (tp, v->_mp_d, vn, u->_mp_d, un); + + rn = un + vn; + rn -= tp[rn-1] == 0; + + t->_mp_size = sign ? - rn : rn; + mpz_swap (r, t); + mpz_clear (t); +} + +void +mpz_mul_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t bits) +{ + mp_size_t un, rn; + mp_size_t limbs; + unsigned shift; + mp_ptr rp; + + un = GMP_ABS (u->_mp_size); + if (un == 0) + { + r->_mp_size = 0; + return; + } + + limbs = bits / GMP_LIMB_BITS; + shift = bits % GMP_LIMB_BITS; + + rn = un + limbs + (shift > 0); + rp = MPZ_REALLOC (r, rn); + if (shift > 0) + { + mp_limb_t cy = mpn_lshift (rp + limbs, u->_mp_d, un, shift); + rp[rn-1] = cy; + rn -= (cy == 0); + } + else + mpn_copyd (rp + limbs, u->_mp_d, un); + + mpn_zero (rp, limbs); + + r->_mp_size = (u->_mp_size < 0) ? - rn : rn; +} + +void +mpz_addmul_ui (mpz_t r, const mpz_t u, unsigned long int v) +{ + mpz_t t; + mpz_init_set_ui (t, v); + mpz_mul (t, u, t); + mpz_add (r, r, t); + mpz_clear (t); +} + +void +mpz_submul_ui (mpz_t r, const mpz_t u, unsigned long int v) +{ + mpz_t t; + mpz_init_set_ui (t, v); + mpz_mul (t, u, t); + mpz_sub (r, r, t); + mpz_clear (t); +} + +void +mpz_addmul (mpz_t r, const mpz_t u, const mpz_t v) +{ + mpz_t t; + mpz_init (t); + mpz_mul (t, u, v); + mpz_add (r, r, t); + mpz_clear (t); +} + +void +mpz_submul (mpz_t r, const mpz_t u, const mpz_t v) +{ + mpz_t t; + mpz_init (t); + mpz_mul (t, u, v); + mpz_sub (r, r, t); + mpz_clear (t); +} + + +/* MPZ division */ +enum mpz_div_round_mode { GMP_DIV_FLOOR, GMP_DIV_CEIL, GMP_DIV_TRUNC }; + +/* Allows q or r to be zero. Returns 1 iff remainder is non-zero. */ +static int +mpz_div_qr (mpz_t q, mpz_t r, + const mpz_t n, const mpz_t d, enum mpz_div_round_mode mode) +{ + mp_size_t ns, ds, nn, dn, qs; + ns = n->_mp_size; + ds = d->_mp_size; + + if (ds == 0) + gmp_die("mpz_div_qr: Divide by zero."); + + if (ns == 0) + { + if (q) + q->_mp_size = 0; + if (r) + r->_mp_size = 0; + return 0; + } + + nn = GMP_ABS (ns); + dn = GMP_ABS (ds); + + qs = ds ^ ns; + + if (nn < dn) + { + if (mode == GMP_DIV_CEIL && qs >= 0) + { + /* q = 1, r = n - d */ + if (r) + mpz_sub (r, n, d); + if (q) + mpz_set_ui (q, 1); + } + else if (mode == GMP_DIV_FLOOR && qs < 0) + { + /* q = -1, r = n + d */ + if (r) + mpz_add (r, n, d); + if (q) + mpz_set_si (q, -1); + } + else + { + /* q = 0, r = d */ + if (r) + mpz_set (r, n); + if (q) + q->_mp_size = 0; + } + return 1; + } + else + { + mp_ptr np, qp; + mp_size_t qn, rn; + mpz_t tq, tr; + + mpz_init_set (tr, n); + np = tr->_mp_d; + + qn = nn - dn + 1; + + if (q) + { + mpz_init2 (tq, qn * GMP_LIMB_BITS); + qp = tq->_mp_d; + } + else + qp = NULL; + + mpn_div_qr (qp, np, nn, d->_mp_d, dn); + + if (qp) + { + qn -= (qp[qn-1] == 0); + + tq->_mp_size = qs < 0 ? -qn : qn; + } + rn = mpn_normalized_size (np, dn); + tr->_mp_size = ns < 0 ? - rn : rn; + + if (mode == GMP_DIV_FLOOR && qs < 0 && rn != 0) + { + if (q) + mpz_sub_ui (tq, tq, 1); + if (r) + mpz_add (tr, tr, d); + } + else if (mode == GMP_DIV_CEIL && qs >= 0 && rn != 0) + { + if (q) + mpz_add_ui (tq, tq, 1); + if (r) + mpz_sub (tr, tr, d); + } + + if (q) + { + mpz_swap (tq, q); + mpz_clear (tq); + } + if (r) + mpz_swap (tr, r); + + mpz_clear (tr); + + return rn != 0; + } +} + +void +mpz_cdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, r, n, d, GMP_DIV_CEIL); +} + +void +mpz_fdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, r, n, d, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_qr (mpz_t q, mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, r, n, d, GMP_DIV_TRUNC); +} + +void +mpz_cdiv_q (mpz_t q, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, NULL, n, d, GMP_DIV_CEIL); +} + +void +mpz_fdiv_q (mpz_t q, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, NULL, n, d, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_q (mpz_t q, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (q, NULL, n, d, GMP_DIV_TRUNC); +} + +void +mpz_cdiv_r (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, GMP_DIV_CEIL); +} + +void +mpz_fdiv_r (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_r (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, GMP_DIV_TRUNC); +} + +void +mpz_mod (mpz_t r, const mpz_t n, const mpz_t d) +{ + mpz_div_qr (NULL, r, n, d, d->_mp_size >= 0 ? GMP_DIV_FLOOR : GMP_DIV_CEIL); +} + +static void +mpz_div_q_2exp (mpz_t q, const mpz_t u, mp_bitcnt_t bit_index, + enum mpz_div_round_mode mode) +{ + mp_size_t un, qn; + mp_size_t limb_cnt; + mp_ptr qp; + int adjust; + + un = u->_mp_size; + if (un == 0) + { + q->_mp_size = 0; + return; + } + limb_cnt = bit_index / GMP_LIMB_BITS; + qn = GMP_ABS (un) - limb_cnt; + bit_index %= GMP_LIMB_BITS; + + if (mode == ((un > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* un != 0 here. */ + /* Note: Below, the final indexing at limb_cnt is valid because at + that point we have qn > 0. */ + adjust = (qn <= 0 + || !mpn_zero_p (u->_mp_d, limb_cnt) + || (u->_mp_d[limb_cnt] + & (((mp_limb_t) 1 << bit_index) - 1))); + else + adjust = 0; + + if (qn <= 0) + qn = 0; + else + { + qp = MPZ_REALLOC (q, qn); + + if (bit_index != 0) + { + mpn_rshift (qp, u->_mp_d + limb_cnt, qn, bit_index); + qn -= qp[qn - 1] == 0; + } + else + { + mpn_copyi (qp, u->_mp_d + limb_cnt, qn); + } + } + + q->_mp_size = qn; + + if (adjust) + mpz_add_ui (q, q, 1); + if (un < 0) + mpz_neg (q, q); +} + +static void +mpz_div_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t bit_index, + enum mpz_div_round_mode mode) +{ + mp_size_t us, un, rn; + mp_ptr rp; + mp_limb_t mask; + + us = u->_mp_size; + if (us == 0 || bit_index == 0) + { + r->_mp_size = 0; + return; + } + rn = (bit_index + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS; + assert (rn > 0); + + rp = MPZ_REALLOC (r, rn); + un = GMP_ABS (us); + + mask = GMP_LIMB_MAX >> (rn * GMP_LIMB_BITS - bit_index); + + if (rn > un) + { + /* Quotient (with truncation) is zero, and remainder is + non-zero */ + if (mode == ((us > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* us != 0 here. */ + { + /* Have to negate and sign extend. */ + mp_size_t i; + + gmp_assert_nocarry (! mpn_neg (rp, u->_mp_d, un)); + for (i = un; i < rn - 1; i++) + rp[i] = GMP_LIMB_MAX; + + rp[rn-1] = mask; + us = -us; + } + else + { + /* Just copy */ + if (r != u) + mpn_copyi (rp, u->_mp_d, un); + + rn = un; + } + } + else + { + if (r != u) + mpn_copyi (rp, u->_mp_d, rn - 1); + + rp[rn-1] = u->_mp_d[rn-1] & mask; + + if (mode == ((us > 0) ? GMP_DIV_CEIL : GMP_DIV_FLOOR)) /* us != 0 here. */ + { + /* If r != 0, compute 2^{bit_count} - r. */ + mpn_neg (rp, rp, rn); + + rp[rn-1] &= mask; + + /* us is not used for anything else, so we can modify it + here to indicate flipped sign. */ + us = -us; + } + } + rn = mpn_normalized_size (rp, rn); + r->_mp_size = us < 0 ? -rn : rn; +} + +void +mpz_cdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_q_2exp (r, u, cnt, GMP_DIV_CEIL); +} + +void +mpz_fdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_q_2exp (r, u, cnt, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_q_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_q_2exp (r, u, cnt, GMP_DIV_TRUNC); +} + +void +mpz_cdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_r_2exp (r, u, cnt, GMP_DIV_CEIL); +} + +void +mpz_fdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_r_2exp (r, u, cnt, GMP_DIV_FLOOR); +} + +void +mpz_tdiv_r_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t cnt) +{ + mpz_div_r_2exp (r, u, cnt, GMP_DIV_TRUNC); +} + +void +mpz_divexact (mpz_t q, const mpz_t n, const mpz_t d) +{ + gmp_assert_nocarry (mpz_div_qr (q, NULL, n, d, GMP_DIV_TRUNC)); +} + +int +mpz_divisible_p (const mpz_t n, const mpz_t d) +{ + return mpz_div_qr (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0; +} + +int +mpz_congruent_p (const mpz_t a, const mpz_t b, const mpz_t m) +{ + mpz_t t; + int res; + + /* a == b (mod 0) iff a == b */ + if (mpz_sgn (m) == 0) + return (mpz_cmp (a, b) == 0); + + mpz_init (t); + mpz_sub (t, a, b); + res = mpz_divisible_p (t, m); + mpz_clear (t); + + return res; +} + +static unsigned long +mpz_div_qr_ui (mpz_t q, mpz_t r, + const mpz_t n, unsigned long d, enum mpz_div_round_mode mode) +{ + unsigned long ret; + mpz_t rr, dd; + + mpz_init (rr); + mpz_init_set_ui (dd, d); + mpz_div_qr (q, rr, n, dd, mode); + mpz_clear (dd); + ret = mpz_get_ui (rr); + + if (r) + mpz_swap (r, rr); + mpz_clear (rr); + + return ret; +} + +unsigned long +mpz_cdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, r, n, d, GMP_DIV_CEIL); +} + +unsigned long +mpz_fdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, r, n, d, GMP_DIV_FLOOR); +} + +unsigned long +mpz_tdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, r, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_cdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_CEIL); +} + +unsigned long +mpz_fdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_FLOOR); +} + +unsigned long +mpz_tdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_cdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_CEIL); +} +unsigned long +mpz_fdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR); +} +unsigned long +mpz_tdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_cdiv_ui (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_CEIL); +} + +unsigned long +mpz_fdiv_ui (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_FLOOR); +} + +unsigned long +mpz_tdiv_ui (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC); +} + +unsigned long +mpz_mod_ui (mpz_t r, const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR); +} + +void +mpz_divexact_ui (mpz_t q, const mpz_t n, unsigned long d) +{ + gmp_assert_nocarry (mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC)); +} + +int +mpz_divisible_ui_p (const mpz_t n, unsigned long d) +{ + return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0; +} + + +/* GCD */ +static mp_limb_t +mpn_gcd_11 (mp_limb_t u, mp_limb_t v) +{ + unsigned shift; + + assert ( (u | v) > 0); + + if (u == 0) + return v; + else if (v == 0) + return u; + + gmp_ctz (shift, u | v); + + u >>= shift; + v >>= shift; + + if ( (u & 1) == 0) + MP_LIMB_T_SWAP (u, v); + + while ( (v & 1) == 0) + v >>= 1; + + while (u != v) + { + if (u > v) + { + u -= v; + do + u >>= 1; + while ( (u & 1) == 0); + } + else + { + v -= u; + do + v >>= 1; + while ( (v & 1) == 0); + } + } + return u << shift; +} + +unsigned long +mpz_gcd_ui (mpz_t g, const mpz_t u, unsigned long v) +{ + mpz_t t; + mpz_init_set_ui(t, v); + mpz_gcd (t, u, t); + if (v > 0) + v = mpz_get_ui (t); + + if (g) + mpz_swap (t, g); + + mpz_clear (t); + + return v; +} + +static mp_bitcnt_t +mpz_make_odd (mpz_t r) +{ + mp_bitcnt_t shift; + + assert (r->_mp_size > 0); + /* Count trailing zeros, equivalent to mpn_scan1, because we know that there is a 1 */ + shift = mpn_common_scan (r->_mp_d[0], 0, r->_mp_d, 0, 0); + mpz_tdiv_q_2exp (r, r, shift); + + return shift; +} + +void +mpz_gcd (mpz_t g, const mpz_t u, const mpz_t v) +{ + mpz_t tu, tv; + mp_bitcnt_t uz, vz, gz; + + if (u->_mp_size == 0) + { + mpz_abs (g, v); + return; + } + if (v->_mp_size == 0) + { + mpz_abs (g, u); + return; + } + + mpz_init (tu); + mpz_init (tv); + + mpz_abs (tu, u); + uz = mpz_make_odd (tu); + mpz_abs (tv, v); + vz = mpz_make_odd (tv); + gz = GMP_MIN (uz, vz); + + if (tu->_mp_size < tv->_mp_size) + mpz_swap (tu, tv); + + mpz_tdiv_r (tu, tu, tv); + if (tu->_mp_size == 0) + { + mpz_swap (g, tv); + } + else + for (;;) + { + int c; + + mpz_make_odd (tu); + c = mpz_cmp (tu, tv); + if (c == 0) + { + mpz_swap (g, tu); + break; + } + if (c < 0) + mpz_swap (tu, tv); + + if (tv->_mp_size == 1) + { + mp_limb_t vl = tv->_mp_d[0]; + mp_limb_t ul = mpz_tdiv_ui (tu, vl); + mpz_set_ui (g, mpn_gcd_11 (ul, vl)); + break; + } + mpz_sub (tu, tu, tv); + } + mpz_clear (tu); + mpz_clear (tv); + mpz_mul_2exp (g, g, gz); +} + +void +mpz_gcdext (mpz_t g, mpz_t s, mpz_t t, const mpz_t u, const mpz_t v) +{ + mpz_t tu, tv, s0, s1, t0, t1; + mp_bitcnt_t uz, vz, gz; + mp_bitcnt_t power; + + if (u->_mp_size == 0) + { + /* g = 0 u + sgn(v) v */ + signed long sign = mpz_sgn (v); + mpz_abs (g, v); + if (s) + s->_mp_size = 0; + if (t) + mpz_set_si (t, sign); + return; + } + + if (v->_mp_size == 0) + { + /* g = sgn(u) u + 0 v */ + signed long sign = mpz_sgn (u); + mpz_abs (g, u); + if (s) + mpz_set_si (s, sign); + if (t) + t->_mp_size = 0; + return; + } + + mpz_init (tu); + mpz_init (tv); + mpz_init (s0); + mpz_init (s1); + mpz_init (t0); + mpz_init (t1); + + mpz_abs (tu, u); + uz = mpz_make_odd (tu); + mpz_abs (tv, v); + vz = mpz_make_odd (tv); + gz = GMP_MIN (uz, vz); + + uz -= gz; + vz -= gz; + + /* Cofactors corresponding to odd gcd. gz handled later. */ + if (tu->_mp_size < tv->_mp_size) + { + mpz_swap (tu, tv); + MPZ_SRCPTR_SWAP (u, v); + MPZ_PTR_SWAP (s, t); + MP_BITCNT_T_SWAP (uz, vz); + } + + /* Maintain + * + * u = t0 tu + t1 tv + * v = s0 tu + s1 tv + * + * where u and v denote the inputs with common factors of two + * eliminated, and det (s0, t0; s1, t1) = 2^p. Then + * + * 2^p tu = s1 u - t1 v + * 2^p tv = -s0 u + t0 v + */ + + /* After initial division, tu = q tv + tu', we have + * + * u = 2^uz (tu' + q tv) + * v = 2^vz tv + * + * or + * + * t0 = 2^uz, t1 = 2^uz q + * s0 = 0, s1 = 2^vz + */ + + mpz_setbit (t0, uz); + mpz_tdiv_qr (t1, tu, tu, tv); + mpz_mul_2exp (t1, t1, uz); + + mpz_setbit (s1, vz); + power = uz + vz; + + if (tu->_mp_size > 0) + { + mp_bitcnt_t shift; + shift = mpz_make_odd (tu); + mpz_mul_2exp (t0, t0, shift); + mpz_mul_2exp (s0, s0, shift); + power += shift; + + for (;;) + { + int c; + c = mpz_cmp (tu, tv); + if (c == 0) + break; + + if (c < 0) + { + /* tv = tv' + tu + * + * u = t0 tu + t1 (tv' + tu) = (t0 + t1) tu + t1 tv' + * v = s0 tu + s1 (tv' + tu) = (s0 + s1) tu + s1 tv' */ + + mpz_sub (tv, tv, tu); + mpz_add (t0, t0, t1); + mpz_add (s0, s0, s1); + + shift = mpz_make_odd (tv); + mpz_mul_2exp (t1, t1, shift); + mpz_mul_2exp (s1, s1, shift); + } + else + { + mpz_sub (tu, tu, tv); + mpz_add (t1, t0, t1); + mpz_add (s1, s0, s1); + + shift = mpz_make_odd (tu); + mpz_mul_2exp (t0, t0, shift); + mpz_mul_2exp (s0, s0, shift); + } + power += shift; + } + } + + /* Now tv = odd part of gcd, and -s0 and t0 are corresponding + cofactors. */ + + mpz_mul_2exp (tv, tv, gz); + mpz_neg (s0, s0); + + /* 2^p g = s0 u + t0 v. Eliminate one factor of two at a time. To + adjust cofactors, we need u / g and v / g */ + + mpz_divexact (s1, v, tv); + mpz_abs (s1, s1); + mpz_divexact (t1, u, tv); + mpz_abs (t1, t1); + + while (power-- > 0) + { + /* s0 u + t0 v = (s0 - v/g) u - (t0 + u/g) v */ + if (mpz_odd_p (s0) || mpz_odd_p (t0)) + { + mpz_sub (s0, s0, s1); + mpz_add (t0, t0, t1); + } + assert (mpz_even_p (t0) && mpz_even_p (s0)); + mpz_tdiv_q_2exp (s0, s0, 1); + mpz_tdiv_q_2exp (t0, t0, 1); + } + + /* Arrange so that |s| < |u| / 2g */ + mpz_add (s1, s0, s1); + if (mpz_cmpabs (s0, s1) > 0) + { + mpz_swap (s0, s1); + mpz_sub (t0, t0, t1); + } + if (u->_mp_size < 0) + mpz_neg (s0, s0); + if (v->_mp_size < 0) + mpz_neg (t0, t0); + + mpz_swap (g, tv); + if (s) + mpz_swap (s, s0); + if (t) + mpz_swap (t, t0); + + mpz_clear (tu); + mpz_clear (tv); + mpz_clear (s0); + mpz_clear (s1); + mpz_clear (t0); + mpz_clear (t1); +} + +void +mpz_lcm (mpz_t r, const mpz_t u, const mpz_t v) +{ + mpz_t g; + + if (u->_mp_size == 0 || v->_mp_size == 0) + { + r->_mp_size = 0; + return; + } + + mpz_init (g); + + mpz_gcd (g, u, v); + mpz_divexact (g, u, g); + mpz_mul (r, g, v); + + mpz_clear (g); + mpz_abs (r, r); +} + +void +mpz_lcm_ui (mpz_t r, const mpz_t u, unsigned long v) +{ + if (v == 0 || u->_mp_size == 0) + { + r->_mp_size = 0; + return; + } + + v /= mpz_gcd_ui (NULL, u, v); + mpz_mul_ui (r, u, v); + + mpz_abs (r, r); +} + +int +mpz_invert (mpz_t r, const mpz_t u, const mpz_t m) +{ + mpz_t g, tr; + int invertible; + + if (u->_mp_size == 0 || mpz_cmpabs_ui (m, 1) <= 0) + return 0; + + mpz_init (g); + mpz_init (tr); + + mpz_gcdext (g, tr, NULL, u, m); + invertible = (mpz_cmp_ui (g, 1) == 0); + + if (invertible) + { + if (tr->_mp_size < 0) + { + if (m->_mp_size >= 0) + mpz_add (tr, tr, m); + else + mpz_sub (tr, tr, m); + } + mpz_swap (r, tr); + } + + mpz_clear (g); + mpz_clear (tr); + return invertible; +} + + +/* Higher level operations (sqrt, pow and root) */ + +void +mpz_pow_ui (mpz_t r, const mpz_t b, unsigned long e) +{ + unsigned long bit; + mpz_t tr; + mpz_init_set_ui (tr, 1); + + bit = GMP_ULONG_HIGHBIT; + do + { + mpz_mul (tr, tr, tr); + if (e & bit) + mpz_mul (tr, tr, b); + bit >>= 1; + } + while (bit > 0); + + mpz_swap (r, tr); + mpz_clear (tr); +} + +void +mpz_ui_pow_ui (mpz_t r, unsigned long blimb, unsigned long e) +{ + mpz_t b; + + mpz_init_set_ui (b, blimb); + mpz_pow_ui (r, b, e); + mpz_clear (b); +} + +void +mpz_powm (mpz_t r, const mpz_t b, const mpz_t e, const mpz_t m) +{ + mpz_t tr; + mpz_t base; + mp_size_t en, mn; + mp_srcptr mp; + struct gmp_div_inverse minv; + unsigned shift; + mp_ptr tp = NULL; + + en = GMP_ABS (e->_mp_size); + mn = GMP_ABS (m->_mp_size); + if (mn == 0) + gmp_die ("mpz_powm: Zero modulo."); + + if (en == 0) + { + mpz_set_ui (r, 1); + return; + } + + mp = m->_mp_d; + mpn_div_qr_invert (&minv, mp, mn); + shift = minv.shift; + + if (shift > 0) + { + /* To avoid shifts, we do all our reductions, except the final + one, using a *normalized* m. */ + minv.shift = 0; + + tp = gmp_xalloc_limbs (mn); + gmp_assert_nocarry (mpn_lshift (tp, mp, mn, shift)); + mp = tp; + } + + mpz_init (base); + + if (e->_mp_size < 0) + { + if (!mpz_invert (base, b, m)) + gmp_die ("mpz_powm: Negative exponent and non-invertible base."); + } + else + { + mp_size_t bn; + mpz_abs (base, b); + + bn = base->_mp_size; + if (bn >= mn) + { + mpn_div_qr_preinv (NULL, base->_mp_d, base->_mp_size, mp, mn, &minv); + bn = mn; + } + + /* We have reduced the absolute value. Now take care of the + sign. Note that we get zero represented non-canonically as + m. */ + if (b->_mp_size < 0) + { + mp_ptr bp = MPZ_REALLOC (base, mn); + gmp_assert_nocarry (mpn_sub (bp, mp, mn, bp, bn)); + bn = mn; + } + base->_mp_size = mpn_normalized_size (base->_mp_d, bn); + } + mpz_init_set_ui (tr, 1); + + while (--en >= 0) + { + mp_limb_t w = e->_mp_d[en]; + mp_limb_t bit; + + bit = GMP_LIMB_HIGHBIT; + do + { + mpz_mul (tr, tr, tr); + if (w & bit) + mpz_mul (tr, tr, base); + if (tr->_mp_size > mn) + { + mpn_div_qr_preinv (NULL, tr->_mp_d, tr->_mp_size, mp, mn, &minv); + tr->_mp_size = mpn_normalized_size (tr->_mp_d, mn); + } + bit >>= 1; + } + while (bit > 0); + } + + /* Final reduction */ + if (tr->_mp_size >= mn) + { + minv.shift = shift; + mpn_div_qr_preinv (NULL, tr->_mp_d, tr->_mp_size, mp, mn, &minv); + tr->_mp_size = mpn_normalized_size (tr->_mp_d, mn); + } + if (tp) + gmp_free (tp); + + mpz_swap (r, tr); + mpz_clear (tr); + mpz_clear (base); +} + +void +mpz_powm_ui (mpz_t r, const mpz_t b, unsigned long elimb, const mpz_t m) +{ + mpz_t e; + + mpz_init_set_ui (e, elimb); + mpz_powm (r, b, e, m); + mpz_clear (e); +} + +/* x=trunc(y^(1/z)), r=y-x^z */ +void +mpz_rootrem (mpz_t x, mpz_t r, const mpz_t y, unsigned long z) +{ + int sgn; + mpz_t t, u; + + sgn = y->_mp_size < 0; + if ((~z & sgn) != 0) + gmp_die ("mpz_rootrem: Negative argument, with even root."); + if (z == 0) + gmp_die ("mpz_rootrem: Zeroth root."); + + if (mpz_cmpabs_ui (y, 1) <= 0) { + if (x) + mpz_set (x, y); + if (r) + r->_mp_size = 0; + return; + } + + mpz_init (u); + mpz_init (t); + mpz_setbit (t, mpz_sizeinbase (y, 2) / z + 1); + + if (z == 2) /* simplify sqrt loop: z-1 == 1 */ + do { + mpz_swap (u, t); /* u = x */ + mpz_tdiv_q (t, y, u); /* t = y/x */ + mpz_add (t, t, u); /* t = y/x + x */ + mpz_tdiv_q_2exp (t, t, 1); /* x'= (y/x + x)/2 */ + } while (mpz_cmpabs (t, u) < 0); /* |x'| < |x| */ + else /* z != 2 */ { + mpz_t v; + + mpz_init (v); + if (sgn) + mpz_neg (t, t); + + do { + mpz_swap (u, t); /* u = x */ + mpz_pow_ui (t, u, z - 1); /* t = x^(z-1) */ + mpz_tdiv_q (t, y, t); /* t = y/x^(z-1) */ + mpz_mul_ui (v, u, z - 1); /* v = x*(z-1) */ + mpz_add (t, t, v); /* t = y/x^(z-1) + x*(z-1) */ + mpz_tdiv_q_ui (t, t, z); /* x'=(y/x^(z-1) + x*(z-1))/z */ + } while (mpz_cmpabs (t, u) < 0); /* |x'| < |x| */ + + mpz_clear (v); + } + + if (r) { + mpz_pow_ui (t, u, z); + mpz_sub (r, y, t); + } + if (x) + mpz_swap (x, u); + mpz_clear (u); + mpz_clear (t); +} + +int +mpz_root (mpz_t x, const mpz_t y, unsigned long z) +{ + int res; + mpz_t r; + + mpz_init (r); + mpz_rootrem (x, r, y, z); + res = r->_mp_size == 0; + mpz_clear (r); + + return res; +} + +/* Compute s = floor(sqrt(u)) and r = u - s^2. Allows r == NULL */ +void +mpz_sqrtrem (mpz_t s, mpz_t r, const mpz_t u) +{ + mpz_rootrem (s, r, u, 2); +} + +void +mpz_sqrt (mpz_t s, const mpz_t u) +{ + mpz_rootrem (s, NULL, u, 2); +} + +int +mpz_perfect_square_p (const mpz_t u) +{ + if (u->_mp_size <= 0) + return (u->_mp_size == 0); + else + return mpz_root (NULL, u, 2); +} + +int +mpn_perfect_square_p (mp_srcptr p, mp_size_t n) +{ + mpz_t t; + + assert (n > 0); + assert (p [n-1] != 0); + return mpz_root (NULL, mpz_roinit_normal_n (t, p, n), 2); +} + +mp_size_t +mpn_sqrtrem (mp_ptr sp, mp_ptr rp, mp_srcptr p, mp_size_t n) +{ + mpz_t s, r, u; + mp_size_t res; + + assert (n > 0); + assert (p [n-1] != 0); + + mpz_init (r); + mpz_init (s); + mpz_rootrem (s, r, mpz_roinit_normal_n (u, p, n), 2); + + assert (s->_mp_size == (n+1)/2); + mpn_copyd (sp, s->_mp_d, s->_mp_size); + mpz_clear (s); + res = r->_mp_size; + if (rp) + mpn_copyd (rp, r->_mp_d, res); + mpz_clear (r); + return res; +} + +/* Combinatorics */ + +void +mpz_mfac_uiui (mpz_t x, unsigned long n, unsigned long m) +{ + mpz_set_ui (x, n + (n == 0)); + if (m + 1 < 2) return; + while (n > m + 1) + mpz_mul_ui (x, x, n -= m); +} + +void +mpz_2fac_ui (mpz_t x, unsigned long n) +{ + mpz_mfac_uiui (x, n, 2); +} + +void +mpz_fac_ui (mpz_t x, unsigned long n) +{ + mpz_mfac_uiui (x, n, 1); +} + +void +mpz_bin_uiui (mpz_t r, unsigned long n, unsigned long k) +{ + mpz_t t; + + mpz_set_ui (r, k <= n); + + if (k > (n >> 1)) + k = (k <= n) ? n - k : 0; + + mpz_init (t); + mpz_fac_ui (t, k); + + for (; k > 0; --k) + mpz_mul_ui (r, r, n--); + + mpz_divexact (r, r, t); + mpz_clear (t); +} + + +/* Primality testing */ + +/* Computes Kronecker (a/b) with odd b, a!=0 and GCD(a,b) = 1 */ +/* Adapted from JACOBI_BASE_METHOD==4 in mpn/generic/jacbase.c */ +static int +gmp_jacobi_coprime (mp_limb_t a, mp_limb_t b) +{ + int c, bit = 0; + + assert (b & 1); + assert (a != 0); + /* assert (mpn_gcd_11 (a, b) == 1); */ + + /* Below, we represent a and b shifted right so that the least + significant one bit is implicit. */ + b >>= 1; + + gmp_ctz(c, a); + a >>= 1; + + do + { + a >>= c; + /* (2/b) = -1 if b = 3 or 5 mod 8 */ + bit ^= c & (b ^ (b >> 1)); + if (a < b) + { + bit ^= a & b; + a = b - a; + b -= a; + } + else + { + a -= b; + assert (a != 0); + } + + gmp_ctz(c, a); + ++c; + } + while (b > 0); + + return bit & 1 ? -1 : 1; +} + +static void +gmp_lucas_step_k_2k (mpz_t V, mpz_t Qk, const mpz_t n) +{ + mpz_mod (Qk, Qk, n); + /* V_{2k} <- V_k ^ 2 - 2Q^k */ + mpz_mul (V, V, V); + mpz_submul_ui (V, Qk, 2); + mpz_tdiv_r (V, V, n); + /* Q^{2k} = (Q^k)^2 */ + mpz_mul (Qk, Qk, Qk); +} + +/* Computes V_k, Q^k (mod n) for the Lucas' sequence */ +/* with P=1, Q=Q; k = (n>>b0)|1. */ +/* Requires an odd n > 4; b0 > 0; -2*Q must not overflow a long */ +/* Returns (U_k == 0) and sets V=V_k and Qk=Q^k. */ +static int +gmp_lucas_mod (mpz_t V, mpz_t Qk, long Q, + mp_bitcnt_t b0, const mpz_t n) +{ + mp_bitcnt_t bs; + mpz_t U; + int res; + + assert (b0 > 0); + assert (Q <= - (LONG_MIN / 2)); + assert (Q >= - (LONG_MAX / 2)); + assert (mpz_cmp_ui (n, 4) > 0); + assert (mpz_odd_p (n)); + + mpz_init_set_ui (U, 1); /* U1 = 1 */ + mpz_set_ui (V, 1); /* V1 = 1 */ + mpz_set_si (Qk, Q); + + for (bs = mpz_sizeinbase (n, 2) - 1; --bs >= b0;) + { + /* U_{2k} <- U_k * V_k */ + mpz_mul (U, U, V); + /* V_{2k} <- V_k ^ 2 - 2Q^k */ + /* Q^{2k} = (Q^k)^2 */ + gmp_lucas_step_k_2k (V, Qk, n); + + /* A step k->k+1 is performed if the bit in $n$ is 1 */ + /* mpz_tstbit(n,bs) or the bit is 0 in $n$ but */ + /* should be 1 in $n+1$ (bs == b0) */ + if (b0 == bs || mpz_tstbit (n, bs)) + { + /* Q^{k+1} <- Q^k * Q */ + mpz_mul_si (Qk, Qk, Q); + /* U_{k+1} <- (U_k + V_k) / 2 */ + mpz_swap (U, V); /* Keep in V the old value of U_k */ + mpz_add (U, U, V); + /* We have to compute U/2, so we need an even value, */ + /* equivalent (mod n) */ + if (mpz_odd_p (U)) + mpz_add (U, U, n); + mpz_tdiv_q_2exp (U, U, 1); + /* V_{k+1} <-(D*U_k + V_k) / 2 = + U_{k+1} + (D-1)/2*U_k = U_{k+1} - 2Q*U_k */ + mpz_mul_si (V, V, -2*Q); + mpz_add (V, U, V); + mpz_tdiv_r (V, V, n); + } + mpz_tdiv_r (U, U, n); + } + + res = U->_mp_size == 0; + mpz_clear (U); + return res; +} + +/* Performs strong Lucas' test on x, with parameters suggested */ +/* for the BPSW test. Qk is only passed to recycle a variable. */ +/* Requires GCD (x,6) = 1.*/ +static int +gmp_stronglucas (const mpz_t x, mpz_t Qk) +{ + mp_bitcnt_t b0; + mpz_t V, n; + mp_limb_t maxD, D; /* The absolute value is stored. */ + long Q; + mp_limb_t tl; + + /* Test on the absolute value. */ + mpz_roinit_normal_n (n, x->_mp_d, GMP_ABS (x->_mp_size)); + + assert (mpz_odd_p (n)); + /* assert (mpz_gcd_ui (NULL, n, 6) == 1); */ + if (mpz_root (Qk, n, 2)) + return 0; /* A square is composite. */ + + /* Check Ds up to square root (in case, n is prime) + or avoid overflows */ + maxD = (Qk->_mp_size == 1) ? Qk->_mp_d [0] - 1 : GMP_LIMB_MAX; + + D = 3; + /* Search a D such that (D/n) = -1 in the sequence 5,-7,9,-11,.. */ + /* For those Ds we have (D/n) = (n/|D|) */ + do + { + if (D >= maxD) + return 1 + (D != GMP_LIMB_MAX); /* (1 + ! ~ D) */ + D += 2; + tl = mpz_tdiv_ui (n, D); + if (tl == 0) + return 0; + } + while (gmp_jacobi_coprime (tl, D) == 1); + + mpz_init (V); + + /* n-(D/n) = n+1 = d*2^{b0}, with d = (n>>b0) | 1 */ + b0 = mpz_scan0 (n, 0); + + /* D= P^2 - 4Q; P = 1; Q = (1-D)/4 */ + Q = (D & 2) ? (long) (D >> 2) + 1 : -(long) (D >> 2); + + if (! gmp_lucas_mod (V, Qk, Q, b0, n)) /* If Ud != 0 */ + while (V->_mp_size != 0 && --b0 != 0) /* while Vk != 0 */ + /* V <- V ^ 2 - 2Q^k */ + /* Q^{2k} = (Q^k)^2 */ + gmp_lucas_step_k_2k (V, Qk, n); + + mpz_clear (V); + return (b0 != 0); +} + +static int +gmp_millerrabin (const mpz_t n, const mpz_t nm1, mpz_t y, + const mpz_t q, mp_bitcnt_t k) +{ + assert (k > 0); + + /* Caller must initialize y to the base. */ + mpz_powm (y, y, q, n); + + if (mpz_cmp_ui (y, 1) == 0 || mpz_cmp (y, nm1) == 0) + return 1; + + while (--k > 0) + { + mpz_powm_ui (y, y, 2, n); + if (mpz_cmp (y, nm1) == 0) + return 1; + /* y == 1 means that the previous y was a non-trivial square root + of 1 (mod n). y == 0 means that n is a power of the base. + In either case, n is not prime. */ + if (mpz_cmp_ui (y, 1) <= 0) + return 0; + } + return 0; +} + +/* This product is 0xc0cfd797, and fits in 32 bits. */ +#define GMP_PRIME_PRODUCT \ + (3UL*5UL*7UL*11UL*13UL*17UL*19UL*23UL*29UL) + +/* Bit (p+1)/2 is set, for each odd prime <= 61 */ +#define GMP_PRIME_MASK 0xc96996dcUL + +int +mpz_probab_prime_p (const mpz_t n, int reps) +{ + mpz_t nm1; + mpz_t q; + mpz_t y; + mp_bitcnt_t k; + int is_prime; + int j; + + /* Note that we use the absolute value of n only, for compatibility + with the real GMP. */ + if (mpz_even_p (n)) + return (mpz_cmpabs_ui (n, 2) == 0) ? 2 : 0; + + /* Above test excludes n == 0 */ + assert (n->_mp_size != 0); + + if (mpz_cmpabs_ui (n, 64) < 0) + return (GMP_PRIME_MASK >> (n->_mp_d[0] >> 1)) & 2; + + if (mpz_gcd_ui (NULL, n, GMP_PRIME_PRODUCT) != 1) + return 0; + + /* All prime factors are >= 31. */ + if (mpz_cmpabs_ui (n, 31*31) < 0) + return 2; + + mpz_init (nm1); + mpz_init (q); + + /* Find q and k, where q is odd and n = 1 + 2**k * q. */ + mpz_abs (nm1, n); + nm1->_mp_d[0] -= 1; + k = mpz_scan1 (nm1, 0); + mpz_tdiv_q_2exp (q, nm1, k); + + /* BPSW test */ + mpz_init_set_ui (y, 2); + is_prime = gmp_millerrabin (n, nm1, y, q, k) && gmp_stronglucas (n, y); + reps -= 24; /* skip the first 24 repetitions */ + + /* Use Miller-Rabin, with a deterministic sequence of bases, a[j] = + j^2 + j + 41 using Euler's polynomial. We potentially stop early, + if a[j] >= n - 1. Since n >= 31*31, this can happen only if reps > + 30 (a[30] == 971 > 31*31 == 961). */ + + for (j = 0; is_prime & (j < reps); j++) + { + mpz_set_ui (y, (unsigned long) j*j+j+41); + if (mpz_cmp (y, nm1) >= 0) + { + /* Don't try any further bases. This "early" break does not affect + the result for any reasonable reps value (<=5000 was tested) */ + assert (j >= 30); + break; + } + is_prime = gmp_millerrabin (n, nm1, y, q, k); + } + mpz_clear (nm1); + mpz_clear (q); + mpz_clear (y); + + return is_prime; +} + + +/* Logical operations and bit manipulation. */ + +/* Numbers are treated as if represented in two's complement (and + infinitely sign extended). For a negative values we get the two's + complement from -x = ~x + 1, where ~ is bitwise complement. + Negation transforms + + xxxx10...0 + + into + + yyyy10...0 + + where yyyy is the bitwise complement of xxxx. So least significant + bits, up to and including the first one bit, are unchanged, and + the more significant bits are all complemented. + + To change a bit from zero to one in a negative number, subtract the + corresponding power of two from the absolute value. This can never + underflow. To change a bit from one to zero, add the corresponding + power of two, and this might overflow. E.g., if x = -001111, the + two's complement is 110001. Clearing the least significant bit, we + get two's complement 110000, and -010000. */ + +int +mpz_tstbit (const mpz_t d, mp_bitcnt_t bit_index) +{ + mp_size_t limb_index; + unsigned shift; + mp_size_t ds; + mp_size_t dn; + mp_limb_t w; + int bit; + + ds = d->_mp_size; + dn = GMP_ABS (ds); + limb_index = bit_index / GMP_LIMB_BITS; + if (limb_index >= dn) + return ds < 0; + + shift = bit_index % GMP_LIMB_BITS; + w = d->_mp_d[limb_index]; + bit = (w >> shift) & 1; + + if (ds < 0) + { + /* d < 0. Check if any of the bits below is set: If so, our bit + must be complemented. */ + if (shift > 0 && (mp_limb_t) (w << (GMP_LIMB_BITS - shift)) > 0) + return bit ^ 1; + while (--limb_index >= 0) + if (d->_mp_d[limb_index] > 0) + return bit ^ 1; + } + return bit; +} + +static void +mpz_abs_add_bit (mpz_t d, mp_bitcnt_t bit_index) +{ + mp_size_t dn, limb_index; + mp_limb_t bit; + mp_ptr dp; + + dn = GMP_ABS (d->_mp_size); + + limb_index = bit_index / GMP_LIMB_BITS; + bit = (mp_limb_t) 1 << (bit_index % GMP_LIMB_BITS); + + if (limb_index >= dn) + { + mp_size_t i; + /* The bit should be set outside of the end of the number. + We have to increase the size of the number. */ + dp = MPZ_REALLOC (d, limb_index + 1); + + dp[limb_index] = bit; + for (i = dn; i < limb_index; i++) + dp[i] = 0; + dn = limb_index + 1; + } + else + { + mp_limb_t cy; + + dp = d->_mp_d; + + cy = mpn_add_1 (dp + limb_index, dp + limb_index, dn - limb_index, bit); + if (cy > 0) + { + dp = MPZ_REALLOC (d, dn + 1); + dp[dn++] = cy; + } + } + + d->_mp_size = (d->_mp_size < 0) ? - dn : dn; +} + +static void +mpz_abs_sub_bit (mpz_t d, mp_bitcnt_t bit_index) +{ + mp_size_t dn, limb_index; + mp_ptr dp; + mp_limb_t bit; + + dn = GMP_ABS (d->_mp_size); + dp = d->_mp_d; + + limb_index = bit_index / GMP_LIMB_BITS; + bit = (mp_limb_t) 1 << (bit_index % GMP_LIMB_BITS); + + assert (limb_index < dn); + + gmp_assert_nocarry (mpn_sub_1 (dp + limb_index, dp + limb_index, + dn - limb_index, bit)); + dn = mpn_normalized_size (dp, dn); + d->_mp_size = (d->_mp_size < 0) ? - dn : dn; +} + +void +mpz_setbit (mpz_t d, mp_bitcnt_t bit_index) +{ + if (!mpz_tstbit (d, bit_index)) + { + if (d->_mp_size >= 0) + mpz_abs_add_bit (d, bit_index); + else + mpz_abs_sub_bit (d, bit_index); + } +} + +void +mpz_clrbit (mpz_t d, mp_bitcnt_t bit_index) +{ + if (mpz_tstbit (d, bit_index)) + { + if (d->_mp_size >= 0) + mpz_abs_sub_bit (d, bit_index); + else + mpz_abs_add_bit (d, bit_index); + } +} + +void +mpz_combit (mpz_t d, mp_bitcnt_t bit_index) +{ + if (mpz_tstbit (d, bit_index) ^ (d->_mp_size < 0)) + mpz_abs_sub_bit (d, bit_index); + else + mpz_abs_add_bit (d, bit_index); +} + +void +mpz_com (mpz_t r, const mpz_t u) +{ + mpz_add_ui (r, u, 1); + mpz_neg (r, r); +} + +void +mpz_and (mpz_t r, const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, rn, i; + mp_ptr up, vp, rp; + + mp_limb_t ux, vx, rx; + mp_limb_t uc, vc, rc; + mp_limb_t ul, vl, rl; + + un = GMP_ABS (u->_mp_size); + vn = GMP_ABS (v->_mp_size); + if (un < vn) + { + MPZ_SRCPTR_SWAP (u, v); + MP_SIZE_T_SWAP (un, vn); + } + if (vn == 0) + { + r->_mp_size = 0; + return; + } + + uc = u->_mp_size < 0; + vc = v->_mp_size < 0; + rc = uc & vc; + + ux = -uc; + vx = -vc; + rx = -rc; + + /* If the smaller input is positive, higher limbs don't matter. */ + rn = vx ? un : vn; + + rp = MPZ_REALLOC (r, rn + (mp_size_t) rc); + + up = u->_mp_d; + vp = v->_mp_d; + + i = 0; + do + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + vl = (vp[i] ^ vx) + vc; + vc = vl < vc; + + rl = ( (ul & vl) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + while (++i < vn); + assert (vc == 0); + + for (; i < rn; i++) + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + rl = ( (ul & vx) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + if (rc) + rp[rn++] = rc; + else + rn = mpn_normalized_size (rp, rn); + + r->_mp_size = rx ? -rn : rn; +} + +void +mpz_ior (mpz_t r, const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, rn, i; + mp_ptr up, vp, rp; + + mp_limb_t ux, vx, rx; + mp_limb_t uc, vc, rc; + mp_limb_t ul, vl, rl; + + un = GMP_ABS (u->_mp_size); + vn = GMP_ABS (v->_mp_size); + if (un < vn) + { + MPZ_SRCPTR_SWAP (u, v); + MP_SIZE_T_SWAP (un, vn); + } + if (vn == 0) + { + mpz_set (r, u); + return; + } + + uc = u->_mp_size < 0; + vc = v->_mp_size < 0; + rc = uc | vc; + + ux = -uc; + vx = -vc; + rx = -rc; + + /* If the smaller input is negative, by sign extension higher limbs + don't matter. */ + rn = vx ? vn : un; + + rp = MPZ_REALLOC (r, rn + (mp_size_t) rc); + + up = u->_mp_d; + vp = v->_mp_d; + + i = 0; + do + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + vl = (vp[i] ^ vx) + vc; + vc = vl < vc; + + rl = ( (ul | vl) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + while (++i < vn); + assert (vc == 0); + + for (; i < rn; i++) + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + rl = ( (ul | vx) ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + if (rc) + rp[rn++] = rc; + else + rn = mpn_normalized_size (rp, rn); + + r->_mp_size = rx ? -rn : rn; +} + +void +mpz_xor (mpz_t r, const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, i; + mp_ptr up, vp, rp; + + mp_limb_t ux, vx, rx; + mp_limb_t uc, vc, rc; + mp_limb_t ul, vl, rl; + + un = GMP_ABS (u->_mp_size); + vn = GMP_ABS (v->_mp_size); + if (un < vn) + { + MPZ_SRCPTR_SWAP (u, v); + MP_SIZE_T_SWAP (un, vn); + } + if (vn == 0) + { + mpz_set (r, u); + return; + } + + uc = u->_mp_size < 0; + vc = v->_mp_size < 0; + rc = uc ^ vc; + + ux = -uc; + vx = -vc; + rx = -rc; + + rp = MPZ_REALLOC (r, un + (mp_size_t) rc); + + up = u->_mp_d; + vp = v->_mp_d; + + i = 0; + do + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + vl = (vp[i] ^ vx) + vc; + vc = vl < vc; + + rl = (ul ^ vl ^ rx) + rc; + rc = rl < rc; + rp[i] = rl; + } + while (++i < vn); + assert (vc == 0); + + for (; i < un; i++) + { + ul = (up[i] ^ ux) + uc; + uc = ul < uc; + + rl = (ul ^ ux) + rc; + rc = rl < rc; + rp[i] = rl; + } + if (rc) + rp[un++] = rc; + else + un = mpn_normalized_size (rp, un); + + r->_mp_size = rx ? -un : un; +} + +static unsigned +gmp_popcount_limb (mp_limb_t x) +{ + unsigned c; + + /* Do 16 bits at a time, to avoid limb-sized constants. */ + int LOCAL_SHIFT_BITS = 16; + for (c = 0; x > 0;) + { + unsigned w = x - ((x >> 1) & 0x5555); + w = ((w >> 2) & 0x3333) + (w & 0x3333); + w = (w >> 4) + w; + w = ((w >> 8) & 0x000f) + (w & 0x000f); + c += w; + if (GMP_LIMB_BITS > LOCAL_SHIFT_BITS) + x >>= LOCAL_SHIFT_BITS; + else + x = 0; + } + return c; +} + +mp_bitcnt_t +mpn_popcount (mp_srcptr p, mp_size_t n) +{ + mp_size_t i; + mp_bitcnt_t c; + + for (c = 0, i = 0; i < n; i++) + c += gmp_popcount_limb (p[i]); + + return c; +} + +mp_bitcnt_t +mpz_popcount (const mpz_t u) +{ + mp_size_t un; + + un = u->_mp_size; + + if (un < 0) + return ~(mp_bitcnt_t) 0; + + return mpn_popcount (u->_mp_d, un); +} + +mp_bitcnt_t +mpz_hamdist (const mpz_t u, const mpz_t v) +{ + mp_size_t un, vn, i; + mp_limb_t uc, vc, ul, vl, comp; + mp_srcptr up, vp; + mp_bitcnt_t c; + + un = u->_mp_size; + vn = v->_mp_size; + + if ( (un ^ vn) < 0) + return ~(mp_bitcnt_t) 0; + + comp = - (uc = vc = (un < 0)); + if (uc) + { + assert (vn < 0); + un = -un; + vn = -vn; + } + + up = u->_mp_d; + vp = v->_mp_d; + + if (un < vn) + MPN_SRCPTR_SWAP (up, un, vp, vn); + + for (i = 0, c = 0; i < vn; i++) + { + ul = (up[i] ^ comp) + uc; + uc = ul < uc; + + vl = (vp[i] ^ comp) + vc; + vc = vl < vc; + + c += gmp_popcount_limb (ul ^ vl); + } + assert (vc == 0); + + for (; i < un; i++) + { + ul = (up[i] ^ comp) + uc; + uc = ul < uc; + + c += gmp_popcount_limb (ul ^ comp); + } + + return c; +} + +mp_bitcnt_t +mpz_scan1 (const mpz_t u, mp_bitcnt_t starting_bit) +{ + mp_ptr up; + mp_size_t us, un, i; + mp_limb_t limb, ux; + + us = u->_mp_size; + un = GMP_ABS (us); + i = starting_bit / GMP_LIMB_BITS; + + /* Past the end there's no 1 bits for u>=0, or an immediate 1 bit + for u<0. Notice this test picks up any u==0 too. */ + if (i >= un) + return (us >= 0 ? ~(mp_bitcnt_t) 0 : starting_bit); + + up = u->_mp_d; + ux = 0; + limb = up[i]; + + if (starting_bit != 0) + { + if (us < 0) + { + ux = mpn_zero_p (up, i); + limb = ~ limb + ux; + ux = - (mp_limb_t) (limb >= ux); + } + + /* Mask to 0 all bits before starting_bit, thus ignoring them. */ + limb &= GMP_LIMB_MAX << (starting_bit % GMP_LIMB_BITS); + } + + return mpn_common_scan (limb, i, up, un, ux); +} + +mp_bitcnt_t +mpz_scan0 (const mpz_t u, mp_bitcnt_t starting_bit) +{ + mp_ptr up; + mp_size_t us, un, i; + mp_limb_t limb, ux; + + us = u->_mp_size; + ux = - (mp_limb_t) (us >= 0); + un = GMP_ABS (us); + i = starting_bit / GMP_LIMB_BITS; + + /* When past end, there's an immediate 0 bit for u>=0, or no 0 bits for + u<0. Notice this test picks up all cases of u==0 too. */ + if (i >= un) + return (ux ? starting_bit : ~(mp_bitcnt_t) 0); + + up = u->_mp_d; + limb = up[i] ^ ux; + + if (ux == 0) + limb -= mpn_zero_p (up, i); /* limb = ~(~limb + zero_p) */ + + /* Mask all bits before starting_bit, thus ignoring them. */ + limb &= GMP_LIMB_MAX << (starting_bit % GMP_LIMB_BITS); + + return mpn_common_scan (limb, i, up, un, ux); +} + + +/* MPZ base conversion. */ + +size_t +mpz_sizeinbase (const mpz_t u, int base) +{ + mp_size_t un; + mp_srcptr up; + mp_ptr tp; + mp_bitcnt_t bits; + struct gmp_div_inverse bi; + size_t ndigits; + + assert (base >= 2); + assert (base <= 62); + + un = GMP_ABS (u->_mp_size); + if (un == 0) + return 1; + + up = u->_mp_d; + + bits = (un - 1) * GMP_LIMB_BITS + mpn_limb_size_in_base_2 (up[un-1]); + switch (base) + { + case 2: + return bits; + case 4: + return (bits + 1) / 2; + case 8: + return (bits + 2) / 3; + case 16: + return (bits + 3) / 4; + case 32: + return (bits + 4) / 5; + /* FIXME: Do something more clever for the common case of base + 10. */ + } + + tp = gmp_xalloc_limbs (un); + mpn_copyi (tp, up, un); + mpn_div_qr_1_invert (&bi, base); + + ndigits = 0; + do + { + ndigits++; + mpn_div_qr_1_preinv (tp, tp, un, &bi); + un -= (tp[un-1] == 0); + } + while (un > 0); + + gmp_free (tp); + return ndigits; +} + +char * +mpz_get_str (char *sp, int base, const mpz_t u) +{ + unsigned bits; + const char *digits; + mp_size_t un; + size_t i, sn; + + digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; + if (base > 1) + { + if (base <= 36) + digits = "0123456789abcdefghijklmnopqrstuvwxyz"; + else if (base > 62) + return NULL; + } + else if (base >= -1) + base = 10; + else + { + base = -base; + if (base > 36) + return NULL; + } + + sn = 1 + mpz_sizeinbase (u, base); + if (!sp) + sp = (char *) gmp_xalloc (1 + sn); + + un = GMP_ABS (u->_mp_size); + + if (un == 0) + { + sp[0] = '0'; + sp[1] = '\0'; + return sp; + } + + i = 0; + + if (u->_mp_size < 0) + sp[i++] = '-'; + + bits = mpn_base_power_of_two_p (base); + + if (bits) + /* Not modified in this case. */ + sn = i + mpn_get_str_bits ((unsigned char *) sp + i, bits, u->_mp_d, un); + else + { + struct mpn_base_info info; + mp_ptr tp; + + mpn_get_base_info (&info, base); + tp = gmp_xalloc_limbs (un); + mpn_copyi (tp, u->_mp_d, un); + + sn = i + mpn_get_str_other ((unsigned char *) sp + i, base, &info, tp, un); + gmp_free (tp); + } + + for (; i < sn; i++) + sp[i] = digits[(unsigned char) sp[i]]; + + sp[sn] = '\0'; + return sp; +} + +int +mpz_set_str (mpz_t r, const char *sp, int base) +{ + unsigned bits, value_of_a; + mp_size_t rn, alloc; + mp_ptr rp; + size_t dn; + int sign; + unsigned char *dp; + + assert (base == 0 || (base >= 2 && base <= 62)); + + while (isspace( (unsigned char) *sp)) + sp++; + + sign = (*sp == '-'); + sp += sign; + + if (base == 0) + { + if (sp[0] == '0') + { + if (sp[1] == 'x' || sp[1] == 'X') + { + base = 16; + sp += 2; + } + else if (sp[1] == 'b' || sp[1] == 'B') + { + base = 2; + sp += 2; + } + else + base = 8; + } + else + base = 10; + } + + if (!*sp) + { + r->_mp_size = 0; + return -1; + } + dp = (unsigned char *) gmp_xalloc (strlen (sp)); + + value_of_a = (base > 36) ? 36 : 10; + for (dn = 0; *sp; sp++) + { + unsigned digit; + + if (isspace ((unsigned char) *sp)) + continue; + else if (*sp >= '0' && *sp <= '9') + digit = *sp - '0'; + else if (*sp >= 'a' && *sp <= 'z') + digit = *sp - 'a' + value_of_a; + else if (*sp >= 'A' && *sp <= 'Z') + digit = *sp - 'A' + 10; + else + digit = base; /* fail */ + + if (digit >= (unsigned) base) + { + gmp_free (dp); + r->_mp_size = 0; + return -1; + } + + dp[dn++] = digit; + } + + if (!dn) + { + gmp_free (dp); + r->_mp_size = 0; + return -1; + } + bits = mpn_base_power_of_two_p (base); + + if (bits > 0) + { + alloc = (dn * bits + GMP_LIMB_BITS - 1) / GMP_LIMB_BITS; + rp = MPZ_REALLOC (r, alloc); + rn = mpn_set_str_bits (rp, dp, dn, bits); + } + else + { + struct mpn_base_info info; + mpn_get_base_info (&info, base); + alloc = (dn + info.exp - 1) / info.exp; + rp = MPZ_REALLOC (r, alloc); + rn = mpn_set_str_other (rp, dp, dn, base, &info); + /* Normalization, needed for all-zero input. */ + assert (rn > 0); + rn -= rp[rn-1] == 0; + } + assert (rn <= alloc); + gmp_free (dp); + + r->_mp_size = sign ? - rn : rn; + + return 0; +} + +int +mpz_init_set_str (mpz_t r, const char *sp, int base) +{ + mpz_init (r); + return mpz_set_str (r, sp, base); +} + +size_t +mpz_out_str (FILE *stream, int base, const mpz_t x) +{ + char *str; + size_t len; + + str = mpz_get_str (NULL, base, x); + if (!str) + return 0; + len = strlen (str); + len = fwrite (str, 1, len, stream); + gmp_free (str); + return len; +} + + +static int +gmp_detect_endian (void) +{ + static const int i = 2; + const unsigned char *p = (const unsigned char *) &i; + return 1 - *p; +} + +/* Import and export. Does not support nails. */ +void +mpz_import (mpz_t r, size_t count, int order, size_t size, int endian, + size_t nails, const void *src) +{ + const unsigned char *p; + ptrdiff_t word_step; + mp_ptr rp; + mp_size_t rn; + + /* The current (partial) limb. */ + mp_limb_t limb; + /* The number of bytes already copied to this limb (starting from + the low end). */ + size_t bytes; + /* The index where the limb should be stored, when completed. */ + mp_size_t i; + + if (nails != 0) + gmp_die ("mpz_import: Nails not supported."); + + assert (order == 1 || order == -1); + assert (endian >= -1 && endian <= 1); + + if (endian == 0) + endian = gmp_detect_endian (); + + p = (unsigned char *) src; + + word_step = (order != endian) ? 2 * size : 0; + + /* Process bytes from the least significant end, so point p at the + least significant word. */ + if (order == 1) + { + p += size * (count - 1); + word_step = - word_step; + } + + /* And at least significant byte of that word. */ + if (endian == 1) + p += (size - 1); + + rn = (size * count + sizeof(mp_limb_t) - 1) / sizeof(mp_limb_t); + rp = MPZ_REALLOC (r, rn); + + for (limb = 0, bytes = 0, i = 0; count > 0; count--, p += word_step) + { + size_t j; + for (j = 0; j < size; j++, p -= (ptrdiff_t) endian) + { + limb |= (mp_limb_t) *p << (bytes++ * CHAR_BIT); + if (bytes == sizeof(mp_limb_t)) + { + rp[i++] = limb; + bytes = 0; + limb = 0; + } + } + } + assert (i + (bytes > 0) == rn); + if (limb != 0) + rp[i++] = limb; + else + i = mpn_normalized_size (rp, i); + + r->_mp_size = i; +} + +void * +mpz_export (void *r, size_t *countp, int order, size_t size, int endian, + size_t nails, const mpz_t u) +{ + size_t count; + mp_size_t un; + + if (nails != 0) + gmp_die ("mpz_import: Nails not supported."); + + assert (order == 1 || order == -1); + assert (endian >= -1 && endian <= 1); + assert (size > 0 || u->_mp_size == 0); + + un = u->_mp_size; + count = 0; + if (un != 0) + { + size_t k; + unsigned char *p; + ptrdiff_t word_step; + /* The current (partial) limb. */ + mp_limb_t limb; + /* The number of bytes left to do in this limb. */ + size_t bytes; + /* The index where the limb was read. */ + mp_size_t i; + + un = GMP_ABS (un); + + /* Count bytes in top limb. */ + limb = u->_mp_d[un-1]; + assert (limb != 0); + + k = (GMP_LIMB_BITS <= CHAR_BIT); + if (!k) + { + do { + int LOCAL_CHAR_BIT = CHAR_BIT; + k++; limb >>= LOCAL_CHAR_BIT; + } while (limb != 0); + } + /* else limb = 0; */ + + count = (k + (un-1) * sizeof (mp_limb_t) + size - 1) / size; + + if (!r) + r = gmp_xalloc (count * size); + + if (endian == 0) + endian = gmp_detect_endian (); + + p = (unsigned char *) r; + + word_step = (order != endian) ? 2 * size : 0; + + /* Process bytes from the least significant end, so point p at the + least significant word. */ + if (order == 1) + { + p += size * (count - 1); + word_step = - word_step; + } + + /* And at least significant byte of that word. */ + if (endian == 1) + p += (size - 1); + + for (bytes = 0, i = 0, k = 0; k < count; k++, p += word_step) + { + size_t j; + for (j = 0; j < size; ++j, p -= (ptrdiff_t) endian) + { + if (sizeof (mp_limb_t) == 1) + { + if (i < un) + *p = u->_mp_d[i++]; + else + *p = 0; + } + else + { + int LOCAL_CHAR_BIT = CHAR_BIT; + if (bytes == 0) + { + if (i < un) + limb = u->_mp_d[i++]; + bytes = sizeof (mp_limb_t); + } + *p = limb; + limb >>= LOCAL_CHAR_BIT; + bytes--; + } + } + } + assert (i == un); + assert (k == count); + } + + if (countp) + *countp = count; + + return r; +} diff --git a/libguile/mini-gmp.h b/libguile/mini-gmp.h new file mode 100644 index 000000000..d575f7d13 --- /dev/null +++ b/libguile/mini-gmp.h @@ -0,0 +1,305 @@ +/* mini-gmp, a minimalistic implementation of a GNU GMP subset. + +Copyright 2011-2015, 2017, 2019-2020 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of either: + + * the GNU Lesser General Public License as published by the Free + Software Foundation; either version 3 of the License, or (at your + option) any later version. + +or + + * the GNU General Public License as published by the Free Software + Foundation; either version 2 of the License, or (at your option) any + later version. + +or both in parallel, as here. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received copies of the GNU General Public License and the +GNU Lesser General Public License along with the GNU MP Library. If not, +see https://www.gnu.org/licenses/. */ + +/* About mini-gmp: This is a minimal implementation of a subset of the + GMP interface. It is intended for inclusion into applications which + have modest bignums needs, as a fallback when the real GMP library + is not installed. + + This file defines the public interface. */ + +#ifndef __MINI_GMP_H__ +#define __MINI_GMP_H__ + +/* For size_t */ +#include <stddef.h> + +#if defined (__cplusplus) +extern "C" { +#endif + +void mp_set_memory_functions (void *(*) (size_t), + void *(*) (void *, size_t, size_t), + void (*) (void *, size_t)); + +void mp_get_memory_functions (void *(**) (size_t), + void *(**) (void *, size_t, size_t), + void (**) (void *, size_t)); + +#ifndef MINI_GMP_LIMB_TYPE +#define MINI_GMP_LIMB_TYPE long +#endif + +typedef unsigned MINI_GMP_LIMB_TYPE mp_limb_t; +typedef long mp_size_t; +typedef unsigned long mp_bitcnt_t; + +typedef mp_limb_t *mp_ptr; +typedef const mp_limb_t *mp_srcptr; + +typedef struct +{ + int _mp_alloc; /* Number of *limbs* allocated and pointed + to by the _mp_d field. */ + int _mp_size; /* abs(_mp_size) is the number of limbs the + last field points to. If _mp_size is + negative this is a negative number. */ + mp_limb_t *_mp_d; /* Pointer to the limbs. */ +} __mpz_struct; + +typedef __mpz_struct mpz_t[1]; + +typedef __mpz_struct *mpz_ptr; +typedef const __mpz_struct *mpz_srcptr; + +extern const int mp_bits_per_limb; + +void mpn_copyi (mp_ptr, mp_srcptr, mp_size_t); +void mpn_copyd (mp_ptr, mp_srcptr, mp_size_t); +void mpn_zero (mp_ptr, mp_size_t); + +int mpn_cmp (mp_srcptr, mp_srcptr, mp_size_t); +int mpn_zero_p (mp_srcptr, mp_size_t); + +mp_limb_t mpn_add_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_add_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); +mp_limb_t mpn_add (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); + +mp_limb_t mpn_sub_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_sub_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); +mp_limb_t mpn_sub (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); + +mp_limb_t mpn_mul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_addmul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); +mp_limb_t mpn_submul_1 (mp_ptr, mp_srcptr, mp_size_t, mp_limb_t); + +mp_limb_t mpn_mul (mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t); +void mpn_mul_n (mp_ptr, mp_srcptr, mp_srcptr, mp_size_t); +void mpn_sqr (mp_ptr, mp_srcptr, mp_size_t); +int mpn_perfect_square_p (mp_srcptr, mp_size_t); +mp_size_t mpn_sqrtrem (mp_ptr, mp_ptr, mp_srcptr, mp_size_t); + +mp_limb_t mpn_lshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int); +mp_limb_t mpn_rshift (mp_ptr, mp_srcptr, mp_size_t, unsigned int); + +mp_bitcnt_t mpn_scan0 (mp_srcptr, mp_bitcnt_t); +mp_bitcnt_t mpn_scan1 (mp_srcptr, mp_bitcnt_t); + +void mpn_com (mp_ptr, mp_srcptr, mp_size_t); +mp_limb_t mpn_neg (mp_ptr, mp_srcptr, mp_size_t); + +mp_bitcnt_t mpn_popcount (mp_srcptr, mp_size_t); + +mp_limb_t mpn_invert_3by2 (mp_limb_t, mp_limb_t); +#define mpn_invert_limb(x) mpn_invert_3by2 ((x), 0) + +size_t mpn_get_str (unsigned char *, int, mp_ptr, mp_size_t); +mp_size_t mpn_set_str (mp_ptr, const unsigned char *, size_t, int); + +void mpz_init (mpz_t); +void mpz_init2 (mpz_t, mp_bitcnt_t); +void mpz_clear (mpz_t); + +#define mpz_odd_p(z) (((z)->_mp_size != 0) & (int) (z)->_mp_d[0]) +#define mpz_even_p(z) (! mpz_odd_p (z)) + +int mpz_sgn (const mpz_t); +int mpz_cmp_si (const mpz_t, long); +int mpz_cmp_ui (const mpz_t, unsigned long); +int mpz_cmp (const mpz_t, const mpz_t); +int mpz_cmpabs_ui (const mpz_t, unsigned long); +int mpz_cmpabs (const mpz_t, const mpz_t); +int mpz_cmp_d (const mpz_t, double); +int mpz_cmpabs_d (const mpz_t, double); + +void mpz_abs (mpz_t, const mpz_t); +void mpz_neg (mpz_t, const mpz_t); +void mpz_swap (mpz_t, mpz_t); + +void mpz_add_ui (mpz_t, const mpz_t, unsigned long); +void mpz_add (mpz_t, const mpz_t, const mpz_t); +void mpz_sub_ui (mpz_t, const mpz_t, unsigned long); +void mpz_ui_sub (mpz_t, unsigned long, const mpz_t); +void mpz_sub (mpz_t, const mpz_t, const mpz_t); + +void mpz_mul_si (mpz_t, const mpz_t, long int); +void mpz_mul_ui (mpz_t, const mpz_t, unsigned long int); +void mpz_mul (mpz_t, const mpz_t, const mpz_t); +void mpz_mul_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_addmul_ui (mpz_t, const mpz_t, unsigned long int); +void mpz_addmul (mpz_t, const mpz_t, const mpz_t); +void mpz_submul_ui (mpz_t, const mpz_t, unsigned long int); +void mpz_submul (mpz_t, const mpz_t, const mpz_t); + +void mpz_cdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_fdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_tdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_cdiv_q (mpz_t, const mpz_t, const mpz_t); +void mpz_fdiv_q (mpz_t, const mpz_t, const mpz_t); +void mpz_tdiv_q (mpz_t, const mpz_t, const mpz_t); +void mpz_cdiv_r (mpz_t, const mpz_t, const mpz_t); +void mpz_fdiv_r (mpz_t, const mpz_t, const mpz_t); +void mpz_tdiv_r (mpz_t, const mpz_t, const mpz_t); + +void mpz_cdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_fdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_tdiv_q_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_cdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_fdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); +void mpz_tdiv_r_2exp (mpz_t, const mpz_t, mp_bitcnt_t); + +void mpz_mod (mpz_t, const mpz_t, const mpz_t); + +void mpz_divexact (mpz_t, const mpz_t, const mpz_t); + +int mpz_divisible_p (const mpz_t, const mpz_t); +int mpz_congruent_p (const mpz_t, const mpz_t, const mpz_t); + +unsigned long mpz_cdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); +unsigned long mpz_fdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); +unsigned long mpz_tdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long); +unsigned long mpz_cdiv_q_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_fdiv_q_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_tdiv_q_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_cdiv_r_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_fdiv_r_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_tdiv_r_ui (mpz_t, const mpz_t, unsigned long); +unsigned long mpz_cdiv_ui (const mpz_t, unsigned long); +unsigned long mpz_fdiv_ui (const mpz_t, unsigned long); +unsigned long mpz_tdiv_ui (const mpz_t, unsigned long); + +unsigned long mpz_mod_ui (mpz_t, const mpz_t, unsigned long); + +void mpz_divexact_ui (mpz_t, const mpz_t, unsigned long); + +int mpz_divisible_ui_p (const mpz_t, unsigned long); + +unsigned long mpz_gcd_ui (mpz_t, const mpz_t, unsigned long); +void mpz_gcd (mpz_t, const mpz_t, const mpz_t); +void mpz_gcdext (mpz_t, mpz_t, mpz_t, const mpz_t, const mpz_t); +void mpz_lcm_ui (mpz_t, const mpz_t, unsigned long); +void mpz_lcm (mpz_t, const mpz_t, const mpz_t); +int mpz_invert (mpz_t, const mpz_t, const mpz_t); + +void mpz_sqrtrem (mpz_t, mpz_t, const mpz_t); +void mpz_sqrt (mpz_t, const mpz_t); +int mpz_perfect_square_p (const mpz_t); + +void mpz_pow_ui (mpz_t, const mpz_t, unsigned long); +void mpz_ui_pow_ui (mpz_t, unsigned long, unsigned long); +void mpz_powm (mpz_t, const mpz_t, const mpz_t, const mpz_t); +void mpz_powm_ui (mpz_t, const mpz_t, unsigned long, const mpz_t); + +void mpz_rootrem (mpz_t, mpz_t, const mpz_t, unsigned long); +int mpz_root (mpz_t, const mpz_t, unsigned long); + +void mpz_fac_ui (mpz_t, unsigned long); +void mpz_2fac_ui (mpz_t, unsigned long); +void mpz_mfac_uiui (mpz_t, unsigned long, unsigned long); +void mpz_bin_uiui (mpz_t, unsigned long, unsigned long); + +int mpz_probab_prime_p (const mpz_t, int); + +int mpz_tstbit (const mpz_t, mp_bitcnt_t); +void mpz_setbit (mpz_t, mp_bitcnt_t); +void mpz_clrbit (mpz_t, mp_bitcnt_t); +void mpz_combit (mpz_t, mp_bitcnt_t); + +void mpz_com (mpz_t, const mpz_t); +void mpz_and (mpz_t, const mpz_t, const mpz_t); +void mpz_ior (mpz_t, const mpz_t, const mpz_t); +void mpz_xor (mpz_t, const mpz_t, const mpz_t); + +mp_bitcnt_t mpz_popcount (const mpz_t); +mp_bitcnt_t mpz_hamdist (const mpz_t, const mpz_t); +mp_bitcnt_t mpz_scan0 (const mpz_t, mp_bitcnt_t); +mp_bitcnt_t mpz_scan1 (const mpz_t, mp_bitcnt_t); + +int mpz_fits_slong_p (const mpz_t); +int mpz_fits_ulong_p (const mpz_t); +long int mpz_get_si (const mpz_t); +unsigned long int mpz_get_ui (const mpz_t); +double mpz_get_d (const mpz_t); +size_t mpz_size (const mpz_t); +mp_limb_t mpz_getlimbn (const mpz_t, mp_size_t); + +void mpz_realloc2 (mpz_t, mp_bitcnt_t); +mp_srcptr mpz_limbs_read (mpz_srcptr); +mp_ptr mpz_limbs_modify (mpz_t, mp_size_t); +mp_ptr mpz_limbs_write (mpz_t, mp_size_t); +void mpz_limbs_finish (mpz_t, mp_size_t); +mpz_srcptr mpz_roinit_n (mpz_t, mp_srcptr, mp_size_t); + +#define MPZ_ROINIT_N(xp, xs) {{0, (xs),(xp) }} + +void mpz_set_si (mpz_t, signed long int); +void mpz_set_ui (mpz_t, unsigned long int); +void mpz_set (mpz_t, const mpz_t); +void mpz_set_d (mpz_t, double); + +void mpz_init_set_si (mpz_t, signed long int); +void mpz_init_set_ui (mpz_t, unsigned long int); +void mpz_init_set (mpz_t, const mpz_t); +void mpz_init_set_d (mpz_t, double); + +size_t mpz_sizeinbase (const mpz_t, int); +char *mpz_get_str (char *, int, const mpz_t); +int mpz_set_str (mpz_t, const char *, int); +int mpz_init_set_str (mpz_t, const char *, int); + +/* This long list taken from gmp.h. */ +/* For reference, "defined(EOF)" cannot be used here. In g++ 2.95.4, + <iostream> defines EOF but not FILE. */ +#if defined (FILE) \ + || defined (H_STDIO) \ + || defined (_H_STDIO) /* AIX */ \ + || defined (_STDIO_H) /* glibc, Sun, SCO */ \ + || defined (_STDIO_H_) /* BSD, OSF */ \ + || defined (__STDIO_H) /* Borland */ \ + || defined (__STDIO_H__) /* IRIX */ \ + || defined (_STDIO_INCLUDED) /* HPUX */ \ + || defined (__dj_include_stdio_h_) /* DJGPP */ \ + || defined (_FILE_DEFINED) /* Microsoft */ \ + || defined (__STDIO__) /* Apple MPW MrC */ \ + || defined (_MSL_STDIO_H) /* Metrowerks */ \ + || defined (_STDIO_H_INCLUDED) /* QNX4 */ \ + || defined (_ISO_STDIO_ISO_H) /* Sun C++ */ \ + || defined (__STDIO_LOADED) /* VMS */ \ + || defined (__DEFINED_FILE) /* musl */ +size_t mpz_out_str (FILE *, int, const mpz_t); +#endif + +void mpz_import (mpz_t, size_t, int, size_t, int, size_t, const void *); +void *mpz_export (void *, size_t *, int, size_t, int, size_t, const mpz_t); + +#if defined (__cplusplus) +} +#endif +#endif /* __MINI_GMP_H__ */ diff --git a/libguile/numbers.c b/libguile/numbers.c index 19d2b2d87..107a05a9b 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -110,9 +110,10 @@ verify (SCM_MOST_POSITIVE_FIXNUM <= (mp_limb_t) -1); (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \ || ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG)) -#if ! HAVE_DECL_MPZ_INITS +#if (! HAVE_DECL_MPZ_INITS) || SCM_ENABLE_MINI_GMP -/* GMP < 5.0.0 lacks `mpz_inits' and `mpz_clears'. Provide them. */ +/* GMP < 5.0.0 and mini-gmp lack `mpz_inits' and `mpz_clears'. Provide + them. */ #define VARARG_MPZ_ITERATOR(func) \ static void \ @@ -398,7 +399,15 @@ scm_i_big2dbl_2exp (SCM b, long *expon_p) { long expon; - double signif = mpz_get_d_2exp (&expon, SCM_I_BIG_MPZ (b)); + double signif; +#if SCM_ENABLE_MINI_GMP + int iexpon; + signif = mpz_get_d (SCM_I_BIG_MPZ (b)); + signif = frexp (signif, &iexpon); + expon = (long) iexpon; +#else + signif = mpz_get_d_2exp (&expon, SCM_I_BIG_MPZ (b)); +#endif scm_remember_upto_here_1 (b); *expon_p = expon + shift; return signif; diff --git a/libguile/numbers.h b/libguile/numbers.h index 02503ad4a..7fe807111 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -22,7 +22,12 @@ +#include "libguile/scm.h" +#if SCM_ENABLE_MINI_GMP +#include "libguile/mini-gmp.h" +#else #include <gmp.h> +#endif #include "libguile/error.h" #include "libguile/gc.h" diff --git a/libguile/ports.c b/libguile/ports.c index 65823f9d7..c25c20709 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,4 +1,4 @@ -/* Copyright 1995-2001,2003-2004,2006-2019 +/* Copyright 1995-2001,2003-2004,2006-2019,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -1948,14 +1948,7 @@ peek_iconv_codepoint (SCM port, SCM *buf, size_t *cur, size_t *len) *len = input_size; if (input_size == 0) /* Normal EOF. */ - { - /* Make sure iconv descriptors have been opened even if - there were no bytes, to be sure that a decoding error - is signalled if the encoding itself was invalid. */ - scm_port_acquire_iconv_descriptors (port, NULL, NULL); - scm_port_release_iconv_descriptors (port); - return EOF; - } + return EOF; /* EOF found in the middle of a multibyte character. */ if (scm_is_eq (SCM_PORT (port)->conversion_strategy, diff --git a/libguile/random.c b/libguile/random.c index 6fd567cca..63da7f5d6 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -30,7 +30,12 @@ #include <sys/types.h> #include <unistd.h> +#include "scm.h" +#if SCM_ENABLE_MINI_GMP +#include "mini-gmp.h" +#else #include <gmp.h> +#endif #include "arrays.h" #include "feature.h" diff --git a/libguile/read.c b/libguile/read.c index 51dffbf3a..3030b27ed 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1,4 +1,4 @@ -/* Copyright 1995-1997,1999-2001,2003-2004,2006-2012,2014-2020 +/* Copyright 1995-1997,1999-2001,2003-2004,2006-2012,2014-2021 Free Software Foundation, Inc. This file is part of Guile. @@ -69,16 +69,9 @@ SCM_GLOBAL_SYMBOL (scm_sym_dot, "."); -SCM_SYMBOL (scm_keyword_prefix, "prefix"); -SCM_SYMBOL (scm_keyword_postfix, "postfix"); SCM_SYMBOL (sym_nil, "nil"); SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1"); -/* SRFI-105 curly infix expression support */ -SCM_SYMBOL (sym_nfx, "$nfx$"); -SCM_SYMBOL (sym_bracket_list, "$bracket-list$"); -SCM_SYMBOL (sym_bracket_apply, "$bracket-apply$"); - scm_t_option scm_read_opts[] = { { SCM_OPTION_BOOLEAN, "positions", 1, @@ -100,47 +93,6 @@ scm_t_option scm_read_opts[] = { 0, }, }; -/* Internal read options structure. This is initialized by 'scm_read' - from the global and per-port read options, and a pointer is passed - down to all helper functions. */ - -enum t_keyword_style - { - KEYWORD_STYLE_HASH_PREFIX, - KEYWORD_STYLE_PREFIX, - KEYWORD_STYLE_POSTFIX - }; - -struct t_read_opts -{ - enum t_keyword_style keyword_style; - unsigned int record_positions_p : 1; - unsigned int case_insensitive_p : 1; - unsigned int r6rs_escapes_p : 1; - unsigned int square_brackets_p : 1; - unsigned int hungry_eol_escapes_p : 1; - unsigned int curly_infix_p : 1; - unsigned int neoteric_p : 1; - unsigned int r7rs_symbols_p : 1; -}; - -typedef struct t_read_opts scm_t_read_opts; - - -/* - Give meaningful error messages for errors - - We use the format - - FILE:LINE:COL: MESSAGE - This happened in .... - - This is not standard GNU format, but the test-suite likes the real - message to be in front. - - */ - - void scm_i_input_error (char const *function, SCM port, const char *message, SCM arg) @@ -179,22 +131,6 @@ SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0, } #undef FUNC_NAME -/* A fluid referring to an association list mapping extra hash - characters to procedures. */ -static SCM *scm_i_read_hash_procedures; - -static SCM -scm_i_read_hash_procedures_ref (void) -{ - return scm_fluid_ref (*scm_i_read_hash_procedures); -} - -static void -scm_i_read_hash_procedures_set_x (SCM value) -{ - scm_fluid_set_x (*scm_i_read_hash_procedures, value); -} - /* Token readers. */ @@ -233,9 +169,7 @@ scm_i_read_hash_procedures_set_x (SCM value) #define CHAR_IS_DELIMITER(c) \ (CHAR_IS_R5RS_DELIMITER (c) \ - || (((c) == ']' || (c) == '[') && (opts->square_brackets_p \ - || opts->curly_infix_p)) \ - || (((c) == '}' || (c) == '{') && opts->curly_infix_p)) + || (((c) == ']' || (c) == '['))) /* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical Structure''. */ @@ -246,8 +180,8 @@ scm_i_read_hash_procedures_set_x (SCM value) /* Read an SCSH block comment. */ static SCM scm_read_scsh_block_comment (scm_t_wchar, SCM); static SCM scm_read_r6rs_block_comment (scm_t_wchar, SCM); -static SCM scm_read_commented_expression (scm_t_wchar, SCM, scm_t_read_opts *); -static SCM scm_read_shebang (scm_t_wchar, SCM, scm_t_read_opts *); +static SCM scm_read_commented_expression (scm_t_wchar, SCM); +static SCM scm_read_shebang (scm_t_wchar, SCM); static SCM scm_get_hash_procedure (int); /* Read from PORT until a delimiter (e.g., a whitespace) is read. Put the @@ -255,8 +189,7 @@ static SCM scm_get_hash_procedure (int); fewer than BUF_SIZE bytes, non-zero otherwise. READ will be set the number of bytes actually read. */ static int -read_token (SCM port, scm_t_read_opts *opts, - char *buf, size_t buf_size, size_t *read) +read_token (SCM port, char *buf, size_t buf_size, size_t *read) { *read = 0; @@ -286,8 +219,7 @@ read_token (SCM port, scm_t_read_opts *opts, /* Like `read_token', but return either BUFFER, or a GC-allocated buffer if the token doesn't fit in BUFFER_SIZE bytes. */ static char * -read_complete_token (SCM port, scm_t_read_opts *opts, - char *buffer, size_t buffer_size, size_t *read) +read_complete_token (SCM port, char *buffer, size_t buffer_size, size_t *read) { int overflow = 0; size_t bytes_read, overflow_size = 0; @@ -295,7 +227,7 @@ read_complete_token (SCM port, scm_t_read_opts *opts, do { - overflow = read_token (port, opts, buffer, buffer_size, &bytes_read); + overflow = read_token (port, buffer, buffer_size, &bytes_read); if (bytes_read == 0) break; if (overflow || overflow_size != 0) @@ -326,13 +258,13 @@ read_complete_token (SCM port, scm_t_read_opts *opts, else *read = bytes_read; - return (overflow_size > 0 ? overflow_buffer : buffer); + return overflow_size > 0 ? overflow_buffer : buffer; } /* Skip whitespace from PORT and return the first non-whitespace character read. Raise an error on end-of-file. */ static int -flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) +flush_ws (SCM port, const char *eoferr) { scm_t_wchar c; while (1) @@ -369,10 +301,10 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) eoferr = "read_sharp"; goto goteof; case '!': - scm_read_shebang (c, port, opts); + scm_read_shebang (c, port); break; case ';': - scm_read_commented_expression (c, port, opts); + scm_read_commented_expression (c, port); break; case '|': if (scm_is_false (scm_get_hash_procedure (c))) @@ -403,60 +335,32 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) /* Token readers. */ -static SCM scm_read_expression (SCM port, scm_t_read_opts *opts); -static SCM scm_read_sharp (int chr, SCM port, scm_t_read_opts *opts, - SCM line, SCM column); +static SCM scm_read_expression (SCM port); +static SCM scm_read_sharp (int chr, SCM port); static SCM -maybe_annotate_source (SCM x, SCM port, scm_t_read_opts *opts, - SCM line, SCM column) -{ - if ((SCM_I_INUMP (line) && SCM_I_INUM (line) < 0) - || (SCM_I_INUMP (column) && SCM_I_INUM (column) < 1)) - /* This condition can be caused by a user calling - set-port-column!. */ - return x; - - if (opts->record_positions_p) - { - /* We always capture the column after one char of lookahead; - subtract off that lookahead value. */ - column = scm_oneminus (column); - scm_i_set_source_properties_x (x, line, column, SCM_FILENAME (port)); - } - return x; -} - -static SCM -scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) +scm_read_sexp (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_i_lreadparen" { int c; SCM tmp, tl, ans = SCM_EOL; - const int curly_list_p = (chr == '{') && opts->curly_infix_p; - const int terminating_char = ((chr == '{') ? '}' - : ((chr == '[') ? ']' - : ')')); - - /* Need to capture line and column numbers here. */ - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); + const int terminating_char = (chr == '[') ? ']' : ')'; - c = flush_ws (port, opts, FUNC_NAME); + c = flush_ws (port, FUNC_NAME); if (terminating_char == c) return SCM_EOL; scm_ungetc (c, port); - tmp = scm_read_expression (port, opts); + tmp = scm_read_expression (port); /* Note that it is possible for scm_read_expression to return scm_sym_dot, but not as part of a dotted pair: as in #{.}#. So check that it's a real dot by checking `c'. */ if (c == '.' && scm_is_eq (scm_sym_dot, tmp)) { - ans = scm_read_expression (port, opts); - if (terminating_char != (c = flush_ws (port, opts, FUNC_NAME))) + ans = scm_read_expression (port); + if (terminating_char != (c = flush_ws (port, FUNC_NAME))) scm_i_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL); return ans; @@ -465,25 +369,24 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) /* Build the head of the list structure. */ ans = tl = scm_cons (tmp, SCM_EOL); - while (terminating_char != (c = flush_ws (port, opts, FUNC_NAME))) + while (terminating_char != (c = flush_ws (port, FUNC_NAME))) { SCM new_tail; - if (c == ')' || (c == ']' && opts->square_brackets_p) - || ((c == '}' || c == ']') && opts->curly_infix_p)) + if (c == ')' || c == ']') scm_i_input_error (FUNC_NAME, port, "in pair: mismatched close paren: ~A", scm_list_1 (SCM_MAKE_CHAR (c))); scm_ungetc (c, port); - tmp = scm_read_expression (port, opts); + tmp = scm_read_expression (port); /* See above note about scm_sym_dot. */ if (c == '.' && scm_is_eq (scm_sym_dot, tmp)) { - SCM_SETCDR (tl, scm_read_expression (port, opts)); + SCM_SETCDR (tl, scm_read_expression (port)); - c = flush_ws (port, opts, FUNC_NAME); + c = flush_ws (port, FUNC_NAME); if (terminating_char != c) scm_i_input_error (FUNC_NAME, port, "in pair: missing close paren", SCM_EOL); @@ -495,60 +398,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) tl = new_tail; } - if (curly_list_p) - { - /* In addition to finding the length, 'scm_ilength' checks for - improper or circular lists, in which case it returns -1. */ - int len = scm_ilength (ans); - - /* The (len == 0) case is handled above */ - if (len == 1) - /* Return directly to avoid re-annotating the element's source - location with the position of the outer brace. Also, it - might not be possible to annotate the element. */ - return scm_car (ans); /* {e} => e */ - else if (len == 2) - ; /* Leave the list unchanged: {e1 e2} => (e1 e2) */ - else if (len >= 3 && (len & 1)) - { - /* It's a proper list whose length is odd and at least 3. If - the elements at odd indices (the infix operator positions) - are all 'equal?', then it's a simple curly-infix list. - Otherwise it's a mixed curly-infix list. */ - SCM op = scm_cadr (ans); - - /* Check to see if the elements at odd indices are 'equal?' */ - for (tl = scm_cdddr (ans); ; tl = scm_cddr (tl)) - { - if (scm_is_null (tl)) - { - /* Convert simple curly-infix list to prefix: - {a <op> b <op> ...} => (<op> a b ...) */ - tl = ans; - while (scm_is_pair (scm_cdr (tl))) - { - tmp = scm_cddr (tl); - SCM_SETCDR (tl, tmp); - tl = tmp; - } - ans = scm_cons (op, ans); - break; - } - else if (scm_is_false (scm_equal_p (op, scm_car (tl)))) - { - /* Mixed curly-infix list: {e ...} => ($nfx$ e ...) */ - ans = scm_cons (sym_nfx, ans); - break; - } - } - } - else - /* Mixed curly-infix (possibly improper) list: - {e . tail} => ($nfx$ e . tail) */ - ans = scm_cons (sym_nfx, ans); - } - - return maybe_annotate_source (ans, port, opts, line, column); + return ans; } #undef FUNC_NAME @@ -587,27 +437,11 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) } \ } while (0) -static void -skip_intraline_whitespace (SCM port) -{ - scm_t_wchar c; - - do - { - c = scm_getc (port); - if (c == EOF) - return; - } - while (c == '\t' || uc_is_general_category (c, UC_SPACE_SEPARATOR)); - - scm_ungetc (c, port); -} - /* Read either a double-quoted string or an R7RS-style symbol delimited by vertical lines, depending on the value of 'chr' ('"' or '|'). Regardless, the result is always returned as a string. */ static SCM -scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) +scm_read_string_like_syntax (int chr, SCM port) #define FUNC_NAME "scm_lreadr" { /* For strings smaller than C_STR, this function creates only one Scheme @@ -617,10 +451,6 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) size_t c_str_len = 0; scm_t_wchar c, c_str[READER_STRING_BUFFER_SIZE]; - /* Need to capture line and column numbers here. */ - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); - while (chr != (c = scm_getc (port))) { if (c == EOF) @@ -652,8 +482,6 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) lisp modes. */ break; case '\n': - if (opts->hungry_eol_escapes_p) - skip_intraline_whitespace (port); continue; case '0': c = '\0'; @@ -680,23 +508,14 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) c = '\010'; break; case 'x': - if (opts->r6rs_escapes_p || chr == '|') - SCM_READ_HEX_ESCAPE (10, ';'); - else - SCM_READ_HEX_ESCAPE (2, '\0'); + SCM_READ_HEX_ESCAPE (2, '\0'); break; case 'u': - if (!opts->r6rs_escapes_p) - { - SCM_READ_HEX_ESCAPE (4, '\0'); - break; - } + SCM_READ_HEX_ESCAPE (4, '\0'); + break; case 'U': - if (!opts->r6rs_escapes_p) - { - SCM_READ_HEX_ESCAPE (6, '\0'); - break; - } + SCM_READ_HEX_ESCAPE (6, '\0'); + break; default: if (c == chr) break; @@ -721,35 +540,25 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) str = scm_string_concatenate_reverse (str, SCM_UNDEFINED, SCM_UNDEFINED); } - return maybe_annotate_source (str, port, opts, line, column); + return str; } #undef FUNC_NAME static SCM -scm_read_string (int chr, SCM port, scm_t_read_opts *opts) -{ - return scm_read_string_like_syntax (chr, port, opts); -} - -static SCM -scm_read_r7rs_symbol (int chr, SCM port, scm_t_read_opts *opts) +scm_read_string (int chr, SCM port) { - return scm_string_to_symbol (scm_read_string_like_syntax (chr, port, opts)); + return scm_read_string_like_syntax (chr, port); } static SCM -scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) +scm_read_number (scm_t_wchar chr, SCM port) { SCM result, str = SCM_EOL; char local_buffer[READER_BUFFER_SIZE], *buffer; size_t bytes_read; - /* Need to capture line and column numbers here. */ - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); - scm_ungetc (chr, port); - buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, + buffer = read_complete_token (port, local_buffer, sizeof local_buffer, &bytes_read); str = scm_from_port_stringn (buffer, bytes_read, port); @@ -758,12 +567,8 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) if (scm_is_false (result)) { /* Return a symbol instead of a number */ - if (opts->case_insensitive_p) - str = scm_string_downcase_x (str); result = scm_string_to_symbol (str); } - else if (SCM_NIMP (result)) - result = maybe_annotate_source (result, port, opts, line, column); scm_set_port_column_x (port, scm_sum (scm_port_column (port), @@ -772,37 +577,19 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) } static SCM -scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) +scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port) { SCM result; - int ends_with_colon = 0; size_t bytes_read; - int postfix = (opts->keyword_style == KEYWORD_STYLE_POSTFIX); char local_buffer[READER_BUFFER_SIZE], *buffer; SCM str; scm_ungetc (chr, port); - buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, + buffer = read_complete_token (port, local_buffer, sizeof local_buffer, &bytes_read); - if (bytes_read > 0) - ends_with_colon = buffer[bytes_read - 1] == ':'; - - if (postfix && ends_with_colon && (bytes_read > 1)) - { - str = scm_from_port_stringn (buffer, bytes_read - 1, port); - if (opts->case_insensitive_p) - str = scm_string_downcase_x (str); - result = scm_symbol_to_keyword (scm_string_to_symbol (str)); - } - else - { - str = scm_from_port_stringn (buffer, bytes_read, port); - - if (opts->case_insensitive_p) - str = scm_string_downcase_x (str); - result = scm_string_to_symbol (str); - } + str = scm_from_port_stringn (buffer, bytes_read, port); + result = scm_string_to_symbol (str); scm_set_port_column_x (port, scm_sum (scm_port_column (port), @@ -811,7 +598,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) } static SCM -scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) +scm_read_number_and_radix (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_lreadr" { SCM result; @@ -848,7 +635,7 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) radix = 10; } - buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, + buffer = read_complete_token (port, local_buffer, sizeof local_buffer, &read); str = scm_from_port_stringn (buffer, read, port); @@ -869,11 +656,9 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) #undef FUNC_NAME static SCM -scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) +scm_read_quote (int chr, SCM port) { SCM p; - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); switch (chr) { @@ -906,8 +691,7 @@ scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) abort (); } - p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL); - return maybe_annotate_source (p, port, opts, line, column); + return scm_cons2 (p, scm_read_expression (port), SCM_EOL); } SCM_SYMBOL (sym_syntax, "syntax"); @@ -916,11 +700,9 @@ SCM_SYMBOL (sym_unsyntax, "unsyntax"); SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing"); static SCM -scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) +scm_read_syntax (int chr, SCM port) { SCM p; - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); switch (chr) { @@ -953,14 +735,13 @@ scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) abort (); } - p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL); - return maybe_annotate_source (p, port, opts, line, column); + return scm_cons2 (p, scm_read_expression (port), SCM_EOL); } static SCM -scm_read_nil (int chr, SCM port, scm_t_read_opts *opts) +scm_read_nil (int chr, SCM port) { - SCM id = scm_read_mixed_case_symbol (chr, port, opts); + SCM id = scm_read_mixed_case_symbol (chr, port); if (!scm_is_eq (id, sym_nil)) scm_i_input_error ("scm_read_nil", port, @@ -1045,7 +826,7 @@ scm_read_boolean (int chr, SCM port) } static SCM -scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) +scm_read_character (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_lreadr" { char buffer[READER_CHAR_NAME_MAX_SIZE]; @@ -1055,7 +836,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) int overflow; scm_t_port *pt; - overflow = read_token (port, opts, buffer, READER_CHAR_NAME_MAX_SIZE, + overflow = read_token (port, buffer, READER_CHAR_NAME_MAX_SIZE, &bytes_read); if (overflow) scm_i_input_error (FUNC_NAME, port, "character name too long", SCM_EOL); @@ -1068,7 +849,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) "while reading character", SCM_EOL); /* CHR must be a token delimiter, like a whitespace. */ - return (SCM_MAKE_CHAR (chr)); + return SCM_MAKE_CHAR (chr); } pt = SCM_PORT (port); @@ -1155,7 +936,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) #undef FUNC_NAME static SCM -scm_read_keyword (int chr, SCM port, scm_t_read_opts *opts) +scm_read_keyword (int chr, SCM port) { SCM symbol; @@ -1164,25 +945,23 @@ scm_read_keyword (int chr, SCM port, scm_t_read_opts *opts) to adapt to the delimiters currently valid of symbols. XXX: This implementation allows sloppy syntaxes like `#: key'. */ - symbol = scm_read_expression (port, opts); + symbol = scm_read_expression (port); if (!scm_is_symbol (symbol)) scm_i_input_error ("scm_read_keyword", port, "keyword prefix `~a' not followed by a symbol: ~s", scm_list_2 (SCM_MAKE_CHAR (chr), symbol)); - return (scm_symbol_to_keyword (symbol)); + return scm_symbol_to_keyword (symbol); } static SCM -scm_read_vector (int chr, SCM port, scm_t_read_opts *opts, - SCM line, SCM column) +scm_read_vector (int chr, SCM port) { /* Note: We call `scm_read_sexp ()' rather than READER here in order to guarantee that it's going to do what we want. After all, this is an implementation detail of `scm_read_vector ()', not a desirable property. */ - return maybe_annotate_source (scm_vector (scm_read_sexp (chr, port, opts)), - port, opts, line, column); + return scm_vector (scm_read_sexp (chr, port)); } /* Helper used by scm_read_array */ @@ -1220,19 +999,19 @@ read_decimal_integer (SCM port, int c, ssize_t *resp) C is the first character read after the '#'. */ static SCM -scm_read_array (int c, SCM port, scm_t_read_opts *opts, SCM line, SCM column) +scm_read_array (int c, SCM port) { ssize_t rank; scm_t_wchar tag_buf[8]; int tag_len; - SCM tag, shape = SCM_BOOL_F, elements, array; + SCM tag, shape = SCM_BOOL_F, elements; /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but the array code can not deal with zero-length dimensions yet, and we want to allow zero-length vectors, of course. */ if (c == '(') - return scm_read_vector (c, port, opts, line, column); + return scm_read_vector (c, port); /* Disambiguate between '#f' and uniform floating point vectors. */ if (c == 'f') @@ -1319,7 +1098,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, SCM line, SCM column) scm_i_input_error (NULL, port, "missing '(' in vector or array literal", SCM_EOL); - elements = scm_read_sexp (c, port, opts); + elements = scm_read_sexp (c, port); if (scm_is_false (shape)) shape = scm_from_ssize_t (rank); @@ -1345,20 +1124,17 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, SCM line, SCM column) } /* Construct array, annotate with source location, and return. */ - array = scm_list_to_typed_array (tag, shape, elements); - return maybe_annotate_source (array, port, opts, line, column); + return scm_list_to_typed_array (tag, shape, elements); } static SCM -scm_read_srfi4_vector (int chr, SCM port, scm_t_read_opts *opts, - SCM line, SCM column) +scm_read_srfi4_vector (int chr, SCM port) { - return scm_read_array (chr, port, opts, line, column); + return scm_read_array (chr, port); } static SCM -scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, - SCM line, SCM column) +scm_read_bytevector (scm_t_wchar chr, SCM port) { chr = scm_getc (port); if (chr != 'u') @@ -1372,9 +1148,7 @@ scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, if (chr != '(') goto syntax; - return maybe_annotate_source - (scm_u8_list_to_bytevector (scm_read_sexp (chr, port, opts)), - port, opts, line, column); + return scm_u8_list_to_bytevector (scm_read_sexp (chr, port)); syntax: scm_i_input_error ("read_bytevector", port, @@ -1384,8 +1158,7 @@ scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, } static SCM -scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, - SCM line, SCM column) +scm_read_guile_bit_vector (scm_t_wchar chr, SCM port) { /* Read the `#*10101'-style read syntax for bit vectors in Guile. This is terribly inefficient but who cares? */ @@ -1401,9 +1174,7 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, if (chr != EOF) scm_ungetc (chr, port); - return maybe_annotate_source - (scm_list_to_bitvector (scm_reverse_x (s_bits, SCM_EOL)), - port, opts, line, column); + return scm_list_to_bitvector (scm_reverse_x (s_bits, SCM_EOL)); } static SCM @@ -1430,21 +1201,8 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) return SCM_UNSPECIFIED; } -static void set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, - int value); -static void set_port_square_brackets_p (SCM port, scm_t_read_opts *opts, - int value); -static void set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, - int value); -static void set_port_r6rs_hex_escapes_p (SCM port, scm_t_read_opts *opts, - int value); -static void set_port_hungry_eol_escapes_p (SCM port, scm_t_read_opts *opts, - int value); -static void set_port_keyword_style (SCM port, scm_t_read_opts *opts, - enum t_keyword_style value); - static SCM -scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) +scm_read_shebang (scm_t_wchar chr, SCM port) { char name[READER_DIRECTIVE_NAME_MAX_SIZE + 1]; int c; @@ -1462,29 +1220,15 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) { scm_ungetc (c, port); name[i] = '\0'; - if (0 == strcmp ("r6rs", name)) - { - set_port_case_insensitive_p (port, opts, 0); - set_port_r6rs_hex_escapes_p (port, opts, 1); - set_port_square_brackets_p (port, opts, 1); - set_port_keyword_style (port, opts, KEYWORD_STYLE_HASH_PREFIX); - set_port_hungry_eol_escapes_p (port, opts, 1); - } - else if (0 == strcmp ("fold-case", name)) - set_port_case_insensitive_p (port, opts, 1); - else if (0 == strcmp ("no-fold-case", name)) - set_port_case_insensitive_p (port, opts, 0); - else if (0 == strcmp ("curly-infix", name)) - set_port_curly_infix_p (port, opts, 1); - else if (0 == strcmp ("curly-infix-and-bracket-lists", name)) - { - set_port_curly_infix_p (port, opts, 1); - set_port_square_brackets_p (port, opts, 0); - } - else - break; - - return SCM_UNSPECIFIED; + if (0 == strcmp ("r6rs", name) + || 0 == strcmp ("fold-case", name) + || 0 == strcmp ("no-fold-case", name) + || 0 == strcmp ("curly-infix", name) + || 0 == strcmp ("curly-infix-and-bracket-lists", name)) + scm_i_input_error ("skip_block_comment", port, + "unsupported directive: ~s", + scm_list_1 (scm_from_latin1_string (name))); + break; } else { @@ -1536,17 +1280,16 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port) } static SCM -scm_read_commented_expression (scm_t_wchar chr, SCM port, - scm_t_read_opts *opts) +scm_read_commented_expression (scm_t_wchar chr, SCM port) { scm_t_wchar c; - c = flush_ws (port, opts, (char *) NULL); + c = flush_ws (port, (char *) NULL); if (EOF == c) scm_i_input_error ("read_commented_expression", port, "no expression after #; comment", SCM_EOL); scm_ungetc (c, port); - scm_read_expression (port, opts); + scm_read_expression (port); return SCM_UNSPECIFIED; } @@ -1638,78 +1381,47 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) scm_i_input_error ("scm_read_extended_symbol", port, "end of file while reading symbol", SCM_EOL); - return (scm_string_to_symbol (scm_c_substring (buf, 0, len))); + return scm_string_to_symbol (scm_c_substring (buf, 0, len)); } /* Top-level token readers, i.e., dispatchers. */ -static SCM -scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts) -{ - SCM proc; - - proc = scm_get_hash_procedure (chr); - if (scm_is_true (scm_procedure_p (proc))) - { - SCM line = scm_port_line (port); - SCM column = scm_oneminus (scm_port_column (port)); - SCM got; - - got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port); - - if (opts->record_positions_p && SCM_NIMP (got) - && !scm_i_has_source_properties (got)) - scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port)); - - return got; - } - - return SCM_UNSPECIFIED; -} - /* The reader for the sharp `#' character. It basically dispatches reads among the above token readers. */ static SCM -scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, - SCM line, SCM column) +scm_read_sharp (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_lreadr" { - SCM result; - chr = scm_getc (port); - result = scm_read_sharp_extension (chr, port, opts); - if (!scm_is_eq (result, SCM_UNSPECIFIED)) - return result; - switch (chr) { case '\\': - return (scm_read_character (chr, port, opts)); + return scm_read_character (chr, port); case '(': - return (scm_read_vector (chr, port, opts, line, column)); + return scm_read_vector (chr, port); case 's': case 'u': case 'f': case 'c': /* This one may return either a boolean or an SRFI-4 vector. */ - return (scm_read_srfi4_vector (chr, port, opts, line, column)); + return scm_read_srfi4_vector (chr, port); case 'v': - return (scm_read_bytevector (chr, port, opts, line, column)); + return scm_read_bytevector (chr, port); case '*': - return (scm_read_guile_bit_vector (chr, port, opts, line, column)); + return scm_read_guile_bit_vector (chr, port); case 't': case 'T': case 'F': - return (scm_read_boolean (chr, port)); + return scm_read_boolean (chr, port); case ':': - return (scm_read_keyword (chr, port, opts)); + return scm_read_keyword (chr, port); case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '@': - return (scm_read_array (chr, port, opts, line, column)); + return scm_read_array (chr, port); case 'i': case 'e': @@ -1723,46 +1435,32 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, case 'X': case 'I': case 'E': - return (scm_read_number_and_radix (chr, port, opts)); + return scm_read_number_and_radix (chr, port); case '{': - return (scm_read_extended_symbol (chr, port)); + return scm_read_extended_symbol (chr, port); case '!': - return (scm_read_shebang (chr, port, opts)); + return scm_read_shebang (chr, port); case ';': - return (scm_read_commented_expression (chr, port, opts)); + return scm_read_commented_expression (chr, port); case '`': case '\'': case ',': - return (scm_read_syntax (chr, port, opts)); + return scm_read_syntax (chr, port); case 'n': - return (scm_read_nil (chr, port, opts)); + return scm_read_nil (chr, port); + case '|': + return scm_read_r6rs_block_comment (chr, port); default: - result = scm_read_sharp_extension (chr, port, opts); - if (scm_is_eq (result, SCM_UNSPECIFIED)) - { - /* To remain compatible with 1.8 and earlier, the following - characters have lower precedence than `read-hash-extend' - characters. */ - switch (chr) - { - case '|': - return scm_read_r6rs_block_comment (chr, port); - default: - scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S", - scm_list_1 (SCM_MAKE_CHAR (chr))); - } - } - else - return result; + scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S", + scm_list_1 (SCM_MAKE_CHAR (chr))); + return SCM_UNSPECIFIED; } - - return SCM_UNSPECIFIED; } #undef FUNC_NAME static SCM -read_inner_expression (SCM port, scm_t_read_opts *opts) -#define FUNC_NAME "read_inner_expression" +scm_read_expression (SCM port) +#define FUNC_NAME "scm_read_expression" { while (1) { @@ -1776,62 +1474,20 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) case SCM_LINE_INCREMENTORS: break; case ';': - (void) scm_read_semicolon_comment (chr, port); + scm_read_semicolon_comment (chr, port); break; - case '{': - if (opts->curly_infix_p) - { - if (opts->neoteric_p) - return scm_read_sexp (chr, port, opts); - else - { - SCM expr; - - /* Enable neoteric expressions within curly braces */ - opts->neoteric_p = 1; - expr = scm_read_sexp (chr, port, opts); - opts->neoteric_p = 0; - return expr; - } - } - else - return scm_read_mixed_case_symbol (chr, port, opts); case '[': - if (opts->square_brackets_p) - return scm_read_sexp (chr, port, opts); - else if (opts->curly_infix_p) - { - /* The syntax of neoteric expressions requires that '[' be - a delimiter when curly-infix is enabled, so it cannot - be part of an unescaped symbol. We might as well do - something useful with it, so we adopt Kawa's convention: - [...] => ($bracket-list$ ...) */ - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); - return maybe_annotate_source - (scm_cons (sym_bracket_list, scm_read_sexp (chr, port, opts)), - port, opts, line, column); - } - else - return scm_read_mixed_case_symbol (chr, port, opts); case '(': - return (scm_read_sexp (chr, port, opts)); + return scm_read_sexp (chr, port); case '"': - return (scm_read_string (chr, port, opts)); - case '|': - if (opts->r7rs_symbols_p) - return scm_read_r7rs_symbol (chr, port, opts); - else - return scm_read_mixed_case_symbol (chr, port, opts); + return scm_read_string (chr, port); case '\'': case '`': case ',': - return (scm_read_quote (chr, port, opts)); + return scm_read_quote (chr, port); case '#': { - SCM line = scm_port_line (port); - SCM column = scm_port_column (port); - SCM result = scm_read_sharp (chr, port, opts, line, column); + SCM result = scm_read_sharp (chr, port); if (scm_is_eq (result, SCM_UNSPECIFIED)) /* We read a comment or some such. */ break; @@ -1841,136 +1497,82 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) case ')': scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL); break; - case '}': - if (opts->curly_infix_p) - scm_i_input_error (FUNC_NAME, port, "unexpected \"}\"", SCM_EOL); - else - return scm_read_mixed_case_symbol (chr, port, opts); case ']': - if (opts->square_brackets_p) - scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL); - /* otherwise fall through */ + scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL); + break; case EOF: return SCM_EOF_VAL; - case ':': - if (opts->keyword_style == KEYWORD_STYLE_PREFIX) - return scm_symbol_to_keyword (scm_read_expression (port, opts)); - /* Fall through. */ default: { if (((chr >= '0') && (chr <= '9')) || (strchr ("+-.", chr))) - return (scm_read_number (chr, port, opts)); + return scm_read_number (chr, port); else - return (scm_read_mixed_case_symbol (chr, port, opts)); + return scm_read_mixed_case_symbol (chr, port); } } } } #undef FUNC_NAME -static SCM -scm_read_expression (SCM port, scm_t_read_opts *opts) -#define FUNC_NAME "scm_read_expression" -{ - if (!opts->neoteric_p) - return read_inner_expression (port, opts); - else - { - SCM line = SCM_INUM0; - SCM column = SCM_INUM1; - SCM expr; - - if (opts->record_positions_p) - { - /* We need to get the position of the first non-whitespace - character in order to correctly annotate neoteric - expressions. For example, for the expression 'f(x)', the - first call to 'read_inner_expression' reads the 'f' (which - cannot be annotated), and then we later read the '(x)' and - use it to construct the new list (f x). */ - int c = flush_ws (port, opts, (char *) NULL); - if (c == EOF) - return SCM_EOF_VAL; - line = scm_port_line (port); - column = scm_port_column (port); - scm_ungetc (c, port); - } - - expr = read_inner_expression (port, opts); - - /* 'expr' is the first component of the neoteric expression. Now - we loop, and as long as the next character is '(', '[', or '{', - (without any intervening whitespace), we use it to construct a - new expression. For example, f{n - 1}(x) => ((f (- n 1)) x). */ - for (;;) - { - int chr = scm_getc (port); - - if (chr == '(') - /* e(...) => (e ...) */ - expr = scm_cons (expr, scm_read_sexp (chr, port, opts)); - else if (chr == '[') - /* e[...] => ($bracket-apply$ e ...) */ - expr = scm_cons (sym_bracket_apply, - scm_cons (expr, - scm_read_sexp (chr, port, opts))); - else if (chr == '{') - { - SCM arg = scm_read_sexp (chr, port, opts); - - if (scm_is_null (arg)) - expr = scm_list_1 (expr); /* e{} => (e) */ - else - expr = scm_list_2 (expr, arg); /* e{...} => (e {...}) */ - } - else - { - if (chr != EOF) - scm_ungetc (chr, port); - break; - } - maybe_annotate_source (expr, port, opts, line, column); - } - return expr; - } -} -#undef FUNC_NAME - /* Actual reader. */ -static void init_read_options (SCM port, scm_t_read_opts *opts); - -SCM_DEFINE (scm_read, "read", 0, 1, 0, +SCM_DEFINE (scm_primitive_read, "primitive-read", 0, 1, 0, (SCM port), "Read an s-expression from the input port @var{port}, or from\n" "the current input port if @var{port} is not specified.\n" "Any whitespace before the next token is discarded.") -#define FUNC_NAME s_scm_read +#define FUNC_NAME s_scm_primitive_read { - scm_t_read_opts opts; int c; if (SCM_UNBNDP (port)) port = scm_current_input_port (); SCM_VALIDATE_OPINPORT (1, port); - init_read_options (port, &opts); - - c = flush_ws (port, &opts, (char *) NULL); + c = flush_ws (port, (char *) NULL); if (EOF == c) return SCM_EOF_VAL; scm_ungetc (c, port); - return (scm_read_expression (port, &opts)); + return scm_read_expression (port); +} +#undef FUNC_NAME + +static SCM scm_read_var; + +SCM +scm_read (SCM port) +#define FUNC_NAME "read" +{ + if (SCM_UNBNDP (port)) + return scm_call_0 (scm_variable_ref (scm_read_var)); + + return scm_call_1 (scm_variable_ref (scm_read_var), port); } #undef FUNC_NAME +/* A fluid referring to an association list mapping extra hash + characters to procedures. */ +static SCM *scm_i_read_hash_procedures; + +static SCM +scm_i_read_hash_procedures_ref (void) +{ + return scm_fluid_ref (*scm_i_read_hash_procedures); +} + +static void +scm_i_read_hash_procedures_set_x (SCM value) +{ + scm_fluid_set_x (*scm_i_read_hash_procedures, value); +} + /* Manipulate the read-hash-procedures alist. This could be written in Scheme, but maybe it will also be used by C code during initialisation. */ SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0, @@ -2229,163 +1831,6 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0, #undef FUNC_NAME -/* Per-port read options. - - We store per-port read options in the 'port-read-options' port - property, which is stored in the internal port structure. The value - stored is a single integer that contains a two-bit field for each - read option. - - If a bit field contains READ_OPTION_INHERIT (3), that indicates that - the applicable value should be inherited from the corresponding - global read option. Otherwise, the bit field contains the value of - the read option. For boolean read options that have been set - per-port, the possible values are 0 or 1. If the 'keyword_style' - read option has been set per-port, its possible values are those in - 'enum t_keyword_style'. */ - -/* Key to read options in port properties. */ -SCM_SYMBOL (sym_port_read_options, "port-read-options"); - -/* Offsets of bit fields for each per-port override */ -#define READ_OPTION_RECORD_POSITIONS_P 0 -#define READ_OPTION_CASE_INSENSITIVE_P 2 -#define READ_OPTION_KEYWORD_STYLE 4 -#define READ_OPTION_R6RS_ESCAPES_P 6 -#define READ_OPTION_SQUARE_BRACKETS_P 8 -#define READ_OPTION_HUNGRY_EOL_ESCAPES_P 10 -#define READ_OPTION_CURLY_INFIX_P 12 -#define READ_OPTION_R7RS_SYMBOLS_P 14 - -/* The total width in bits of the per-port overrides */ -#define READ_OPTIONS_NUM_BITS 16 - -#define READ_OPTIONS_INHERIT_ALL ((1UL << READ_OPTIONS_NUM_BITS) - 1) -#define READ_OPTIONS_MAX_VALUE READ_OPTIONS_INHERIT_ALL - -#define READ_OPTION_MASK 3 -#define READ_OPTION_INHERIT 3 - -static void -set_port_read_option (SCM port, int option, int new_value) -{ - SCM scm_read_options; - unsigned int read_options; - - new_value &= READ_OPTION_MASK; - - scm_read_options = scm_i_port_property (port, sym_port_read_options); - if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE)) - read_options = scm_to_uint (scm_read_options); - else - read_options = READ_OPTIONS_INHERIT_ALL; - read_options &= ~(READ_OPTION_MASK << option); - read_options |= new_value << option; - scm_read_options = scm_from_uint (read_options); - scm_i_set_port_property_x (port, sym_port_read_options, scm_read_options); -} - -/* Set OPTS and PORT's case-insensitivity according to VALUE. */ -static void -set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, int value) -{ - value = !!value; - opts->case_insensitive_p = value; - set_port_read_option (port, READ_OPTION_CASE_INSENSITIVE_P, value); -} - -/* Set OPTS and PORT's square_brackets_p option according to VALUE. */ -static void -set_port_square_brackets_p (SCM port, scm_t_read_opts *opts, int value) -{ - value = !!value; - opts->square_brackets_p = value; - set_port_read_option (port, READ_OPTION_SQUARE_BRACKETS_P, value); -} - -/* Set OPTS and PORT's curly_infix_p option according to VALUE. */ -static void -set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value) -{ - value = !!value; - opts->curly_infix_p = value; - set_port_read_option (port, READ_OPTION_CURLY_INFIX_P, value); -} - -/* Set OPTS and PORT's r6rs_hex_escapes_p option according to VALUE. */ -static void -set_port_r6rs_hex_escapes_p (SCM port, scm_t_read_opts *opts, int value) -{ - value = !!value; - opts->r6rs_escapes_p = value; - set_port_read_option (port, READ_OPTION_R6RS_ESCAPES_P, value); -} - -static void -set_port_hungry_eol_escapes_p (SCM port, scm_t_read_opts *opts, int value) -{ - value = !!value; - opts->hungry_eol_escapes_p = value; - set_port_read_option (port, READ_OPTION_HUNGRY_EOL_ESCAPES_P, value); -} - -static void -set_port_keyword_style (SCM port, scm_t_read_opts *opts, enum t_keyword_style value) -{ - opts->keyword_style = value; - set_port_read_option (port, READ_OPTION_KEYWORD_STYLE, value); -} - -/* Initialize OPTS based on PORT's read options and the global read - options. */ -static void -init_read_options (SCM port, scm_t_read_opts *opts) -{ - SCM val, scm_read_options; - unsigned int read_options, x; - - scm_read_options = scm_i_port_property (port, sym_port_read_options); - - if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE)) - read_options = scm_to_uint (scm_read_options); - else - read_options = READ_OPTIONS_INHERIT_ALL; - - x = READ_OPTION_MASK & (read_options >> READ_OPTION_KEYWORD_STYLE); - if (x == READ_OPTION_INHERIT) - { - val = SCM_PACK (SCM_KEYWORD_STYLE); - if (scm_is_eq (val, scm_keyword_prefix)) - x = KEYWORD_STYLE_PREFIX; - else if (scm_is_eq (val, scm_keyword_postfix)) - x = KEYWORD_STYLE_POSTFIX; - else - x = KEYWORD_STYLE_HASH_PREFIX; - } - opts->keyword_style = x; - -#define RESOLVE_BOOLEAN_OPTION(NAME, name) \ - do \ - { \ - x = READ_OPTION_MASK & (read_options >> READ_OPTION_ ## NAME); \ - if (x == READ_OPTION_INHERIT) \ - x = !!SCM_ ## NAME; \ - opts->name = x; \ - } \ - while (0) - - RESOLVE_BOOLEAN_OPTION (RECORD_POSITIONS_P, record_positions_p); - RESOLVE_BOOLEAN_OPTION (CASE_INSENSITIVE_P, case_insensitive_p); - RESOLVE_BOOLEAN_OPTION (R6RS_ESCAPES_P, r6rs_escapes_p); - RESOLVE_BOOLEAN_OPTION (SQUARE_BRACKETS_P, square_brackets_p); - RESOLVE_BOOLEAN_OPTION (HUNGRY_EOL_ESCAPES_P, hungry_eol_escapes_p); - RESOLVE_BOOLEAN_OPTION (CURLY_INFIX_P, curly_infix_p); - RESOLVE_BOOLEAN_OPTION (R7RS_SYMBOLS_P, r7rs_symbols_p); - -#undef RESOLVE_BOOLEAN_OPTION - - opts->neoteric_p = 0; -} void scm_init_read () @@ -2399,4 +1844,7 @@ scm_init_read () scm_init_opts (scm_read_options, scm_read_opts); #include "read.x" + + scm_read_var = scm_c_define + ("read", scm_variable_ref (scm_c_lookup (s_scm_primitive_read))); } diff --git a/libguile/read.h b/libguile/read.h index 94d92db4a..c3d62cd15 100644 --- a/libguile/read.h +++ b/libguile/read.h @@ -1,7 +1,7 @@ #ifndef SCM_READ_H #define SCM_READ_H -/* Copyright 1995-1996,2000,2006,2008-2009,2018 +/* Copyright 1995-1996,2000,2006,2008-2009,2018,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -49,6 +49,8 @@ SCM_API SCM scm_sym_dot; +SCM_INTERNAL SCM scm_primitive_read (SCM port); + SCM_API SCM scm_read_options (SCM setting); SCM_API SCM scm_read (SCM port); SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc); diff --git a/libguile/socket.c b/libguile/socket.c index bcd4ab5ca..9b87c0c14 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -49,7 +49,12 @@ #include <netdb.h> #include <arpa/inet.h> +#include "scm.h" +#if SCM_ENABLE_MINI_GMP +#include "mini-gmp.h" +#else #include <gmp.h> +#endif #include "arrays.h" #include "async.h" diff --git a/libguile/syntax.c b/libguile/syntax.c index 2da4e395e..2f416d173 100644 --- a/libguile/syntax.c +++ b/libguile/syntax.c @@ -1,4 +1,4 @@ -/* Copyright 2017-2018 +/* Copyright 2017-2018,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -24,19 +24,39 @@ # include <config.h> #endif +#include "alist.h" #include "eval.h" #include "gsubr.h" #include "keywords.h" #include "modules.h" +#include "pairs.h" #include "ports.h" +#include "srcprop.h" #include "threads.h" #include "variable.h" +#include "vectors.h" #include "syntax.h" +/* The source field was added to syntax objects in Guile 3.0.6. However + there can be older syntax objects present in compiled files that + don't have the source field. If a syntax object has a source field, + its tag will have HAS_SOURCE_WORD_FLAG set. */ +#define HAS_SOURCE_WORD_FLAG 0x100 + +enum +{ + TAG_WORD, + EXPR_WORD, + WRAP_WORD, + MODULE_WORD, + SOURCE_WORD, + WORD_COUNT +}; + static int scm_is_syntax (SCM x) { @@ -56,13 +76,46 @@ SCM_DEFINE (scm_syntax_p, "syntax?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 0, 0, - (SCM exp, SCM wrap, SCM module), +static SCM +sourcev_to_props (SCM v) +{ + SCM props = scm_acons (scm_sym_line, scm_c_vector_ref (v, 1), + scm_acons (scm_sym_column, scm_c_vector_ref (v, 2), + SCM_EOL)); + if (scm_is_true (scm_c_vector_ref (v, 0))) + props = scm_acons (scm_sym_filename, scm_c_vector_ref (v, 0), props); + return props; +} + +static SCM +props_to_sourcev (SCM props) +{ + SCM v = scm_c_make_vector (3, SCM_BOOL_F); + scm_c_vector_set_x (v, 0, scm_assq_ref (props, scm_sym_filename)); + scm_c_vector_set_x (v, 1, scm_assq_ref (props, scm_sym_line)); + scm_c_vector_set_x (v, 2, scm_assq_ref (props, scm_sym_column)); + return v; +} + +SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 1, 0, + (SCM exp, SCM wrap, SCM module, SCM source), "Make a new syntax object.") #define FUNC_NAME s_scm_make_syntax { - return scm_double_cell (scm_tc7_syntax, SCM_UNPACK (exp), - SCM_UNPACK (wrap), SCM_UNPACK (module)); + if (SCM_UNBNDP (source)) + source = scm_source_properties (exp); + if (scm_is_pair (source)) + source = props_to_sourcev (source); + if (!scm_is_vector (source)) + source = SCM_BOOL_F; + + SCM ret = scm_words (scm_tc7_syntax | HAS_SOURCE_WORD_FLAG, WORD_COUNT); + SCM_SET_CELL_OBJECT (ret, EXPR_WORD, exp); + SCM_SET_CELL_OBJECT (ret, WRAP_WORD, wrap); + SCM_SET_CELL_OBJECT (ret, MODULE_WORD, module); + SCM_SET_CELL_OBJECT (ret, SOURCE_WORD, source); + + return ret; } #undef FUNC_NAME @@ -72,7 +125,7 @@ SCM_DEFINE (scm_syntax_expression, "syntax-expression", 1, 0, 0, #define FUNC_NAME s_scm_syntax_expression { SCM_VALIDATE_SYNTAX (1, obj); - return SCM_CELL_OBJECT_1 (obj); + return SCM_CELL_OBJECT (obj, EXPR_WORD); } #undef FUNC_NAME @@ -82,7 +135,7 @@ SCM_DEFINE (scm_syntax_wrap, "syntax-wrap", 1, 0, 0, #define FUNC_NAME s_scm_syntax_wrap { SCM_VALIDATE_SYNTAX (1, obj); - return SCM_CELL_OBJECT_2 (obj); + return SCM_CELL_OBJECT (obj, WRAP_WORD); } #undef FUNC_NAME @@ -92,7 +145,43 @@ SCM_DEFINE (scm_syntax_module, "syntax-module", 1, 0, 0, #define FUNC_NAME s_scm_syntax_module { SCM_VALIDATE_SYNTAX (1, obj); - return SCM_CELL_OBJECT_3 (obj); + return SCM_CELL_OBJECT (obj, MODULE_WORD); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_syntax_source, "syntax-source", 1, 0, 0, + (SCM obj), + "Return the source properties for syntax object @var{obj}, as\n" + "an alist possibly containing the keys @code{filename},\n" + "@code{line}, and @code{column}. Return @code{#f} if no\n" + "source properties are available.") +#define FUNC_NAME s_scm_syntax_source +{ + SCM_VALIDATE_SYNTAX (1, obj); + if (!(SCM_CELL_WORD (obj, TAG_WORD) & HAS_SOURCE_WORD_FLAG)) + return SCM_BOOL_F; + SCM src = SCM_CELL_OBJECT (obj, SOURCE_WORD); + if (scm_is_vector (src)) + src = sourcev_to_props (src); + return src; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_syntax_sourcev, "syntax-sourcev", 1, 0, 0, + (SCM obj), + "Return the source location information for syntax object\n" + "@var{obj}, as a vector of @code{#(@var{filename} @var{line}\n" + "@var{column})}, or @code{#f} if no source properties are\n" + "available.") +#define FUNC_NAME s_scm_syntax_sourcev +{ + SCM_VALIDATE_SYNTAX (1, obj); + if (!(SCM_CELL_WORD (obj, TAG_WORD) & HAS_SOURCE_WORD_FLAG)) + return SCM_BOOL_F; + SCM src = SCM_CELL_OBJECT (obj, SOURCE_WORD); + if (scm_is_null (src) || scm_is_pair (src)) + src = props_to_sourcev (src); + return src; } #undef FUNC_NAME diff --git a/libguile/syntax.h b/libguile/syntax.h index 16229f659..d860a355e 100644 --- a/libguile/syntax.h +++ b/libguile/syntax.h @@ -1,7 +1,7 @@ #ifndef SCM_SYNTAX_H #define SCM_SYNTAX_H -/* Copyright 2017-2018 +/* Copyright 2017-2018,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -23,10 +23,12 @@ #include "libguile/scm.h" SCM_INTERNAL SCM scm_syntax_p (SCM obj); -SCM_INTERNAL SCM scm_make_syntax (SCM exp, SCM wrap, SCM module); +SCM_INTERNAL SCM scm_make_syntax (SCM exp, SCM wrap, SCM module, SCM source); SCM_INTERNAL SCM scm_syntax_expression (SCM obj); SCM_INTERNAL SCM scm_syntax_wrap (SCM obj); SCM_INTERNAL SCM scm_syntax_module (SCM obj); +SCM_INTERNAL SCM scm_syntax_source (SCM obj); +SCM_INTERNAL SCM scm_syntax_sourcev (SCM obj); SCM_INTERNAL void scm_i_syntax_print (SCM obj, SCM port, scm_print_state *pstate); diff --git a/module/Makefile.am b/module/Makefile.am index 45113b542..b836812ac 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -1,6 +1,6 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright (C) 2009-2020 Free Software Foundation, Inc. +## Copyright (C) 2009-2021 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -27,7 +27,7 @@ modpath = VM_TARGETS := system/vm/assembler.go system/vm/disassembler.go $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h -ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm +ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm $(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go @@ -334,7 +334,7 @@ SOURCES = \ system/base/ck.scm \ \ system/foreign.scm \ - \ + system/foreign-library.scm \ system/foreign-object.scm \ \ system/repl/debug.scm \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 89595f3f7..165fa2590 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -375,11 +375,17 @@ If returning early, return the return value of F." (define (resolve-module . args) #f) +;; The definition of "include" needs read-syntax. Replaced later. +(define (read-syntax port) + (let ((datum (read port))) + (if (eof-object? datum) + datum + (datum->syntax #f datum)))) + ;; API provided by psyntax (define syntax-violation #f) (define datum->syntax #f) (define syntax->datum #f) -(define syntax-source #f) (define identifier? #f) (define generate-temporaries #f) (define bound-identifier=? #f) @@ -863,9 +869,19 @@ VALUE." ;;; {Arrays} ;;; -(define (array-shape a) +(define (array-shape array) + "Return a list as long as the rank of @var{array}, where each element +is a two-element list containing the lower and upper bounds of the +corresponding dimension. + +@lisp +(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) (0 5)) +@end lisp + +See also: @code{array-dimensions}, @code{array-rank}." + (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) - (array-dimensions a))) + (array-dimensions array))) @@ -2217,6 +2233,19 @@ name extensions listed in %load-extensions." ;;; Reader code for various "#c" forms. ;;; +(define read-hash-procedures + (fluid->parameter %read-hash-procedures)) + +(define (read-hash-procedure ch) + (assq-ref (read-hash-procedures) ch)) + +(define (read-hash-extend ch proc) + (let ((alist (read-hash-procedures))) + (read-hash-procedures + (if proc + (assq-set! alist ch proc) + (assq-remove! alist ch))))) + (define read-eval? (make-fluid #f)) (read-hash-extend #\. (lambda (c port) @@ -4622,6 +4651,19 @@ R7RS." +;;; {`read' implementation in Scheme.} +;;; +;;; + +(call-with-values (lambda () + (include-from-path "ice-9/read.scm") + (values read read-syntax)) + (lambda (read* read-syntax*) + (set! read read*) + (set! read-syntax read-syntax*))) + + + ;;; {Threads} ;;; @@ -4673,7 +4715,8 @@ R7RS." make-syntax syntax-expression syntax-wrap - syntax-module))) + syntax-module + syntax-sourcev))) diff --git a/module/ice-9/local-eval.scm b/module/ice-9/local-eval.scm index b81daf3e8..ac8838f1b 100644 --- a/module/ice-9/local-eval.scm +++ b/module/ice-9/local-eval.scm @@ -1,6 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- ;;; -;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc. +;;; Copyright (C) 2012, 2013, 2021 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -39,11 +39,6 @@ (syntax-module (lexenv-scope e)) (+ (length (lexenv-boxes e)) (length (lexenv-patterns e)))))) -(define-syntax syntax-object-of - (lambda (form) - (syntax-case form () - ((_ x) #`(quote #,(datum->syntax #'x #'x)))))) - (define-syntax-rule (make-box v) (case-lambda (() v) @@ -55,7 +50,7 @@ (define-syntax-rule (identifier-syntax-from-box box) (make-transformer-from-box - (syntax-object-of box) + (quote-syntax box) (identifier-syntax (id (box)) ((set! id x) (box x))))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 95758255a..554ae0e28 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -5,7 +5,8 @@ (make-syntax (module-ref (current-module) 'make-syntax)) (syntax-expression (module-ref (current-module) 'syntax-expression)) (syntax-wrap (module-ref (current-module) 'syntax-wrap)) - (syntax-module (module-ref (current-module) 'syntax-module))) + (syntax-module (module-ref (current-module) 'syntax-module)) + (syntax-sourcev (module-ref (current-module) 'syntax-sourcev))) (letrec* ((make-void (lambda (src) @@ -126,10 +127,23 @@ (session-id (let ((v (module-variable (current-module) 'syntax-session-id))) (lambda () ((variable-ref v))))) + (sourcev-filename (lambda (s) (vector-ref s 0))) + (sourcev-line (lambda (s) (vector-ref s 1))) + (sourcev-column (lambda (s) (vector-ref s 2))) + (sourcev->alist + (lambda (sourcev) + (letrec* + ((maybe-acons (lambda (k v tail) (if v (acons k v tail) tail)))) + (and sourcev + (maybe-acons + 'filename + (sourcev-filename sourcev) + (list (cons 'line (sourcev-line sourcev)) + (cons 'column (sourcev-column sourcev)))))))) (decorate-source (lambda (e s) (if (and s (supports-source-properties? e)) - (set-source-properties! e s)) + (set-source-properties! e (sourcev->alist s))) e)) (maybe-name-value! (lambda (name val) @@ -137,19 +151,24 @@ (let ((meta (lambda-meta val))) (if (not (assq 'name meta)) (set-lambda-meta! val (acons 'name name meta))))))) - (build-void (lambda (source) (make-void source))) + (build-void (lambda (sourcev) (make-void (sourcev->alist sourcev)))) (build-call - (lambda (source fun-exp arg-exps) - (make-call source fun-exp arg-exps))) + (lambda (sourcev fun-exp arg-exps) + (make-call (sourcev->alist sourcev) fun-exp arg-exps))) (build-conditional - (lambda (source test-exp then-exp else-exp) - (make-conditional source test-exp then-exp else-exp))) + (lambda (sourcev test-exp then-exp else-exp) + (make-conditional + (sourcev->alist sourcev) + test-exp + then-exp + else-exp))) (build-lexical-reference - (lambda (type source name var) (make-lexical-ref source name var))) + (lambda (type sourcev name var) + (make-lexical-ref (sourcev->alist sourcev) name var))) (build-lexical-assignment - (lambda (source name var exp) + (lambda (sourcev name var exp) (maybe-name-value! name exp) - (make-lexical-set source name var exp))) + (make-lexical-set (sourcev->alist sourcev) name var exp))) (analyze-variable (lambda (mod var modref-cont bare-cont) (if (not mod) @@ -171,49 +190,72 @@ (syntax-violation #f "primitive not in operator position" var)) (else (syntax-violation #f "bad module kind" var mod)))))))) (build-global-reference - (lambda (source var mod) + (lambda (sourcev var mod) (analyze-variable mod var - (lambda (mod var public?) (make-module-ref source mod var public?)) - (lambda (mod var) (make-toplevel-ref source mod var))))) + (lambda (mod var public?) + (make-module-ref (sourcev->alist sourcev) mod var public?)) + (lambda (mod var) + (make-toplevel-ref (sourcev->alist sourcev) mod var))))) (build-global-assignment - (lambda (source var exp mod) + (lambda (sourcev var exp mod) (maybe-name-value! var exp) (analyze-variable mod var (lambda (mod var public?) - (make-module-set source mod var public? exp)) - (lambda (mod var) (make-toplevel-set source mod var exp))))) + (make-module-set (sourcev->alist sourcev) mod var public? exp)) + (lambda (mod var) + (make-toplevel-set (sourcev->alist sourcev) mod var exp))))) (build-global-definition - (lambda (source mod var exp) + (lambda (sourcev mod var exp) (maybe-name-value! var exp) - (make-toplevel-define source (and mod (cdr mod)) var exp))) + (make-toplevel-define + (sourcev->alist sourcev) + (and mod (cdr mod)) + var + exp))) (build-simple-lambda (lambda (src req rest vars meta exp) (make-lambda - src + (sourcev->alist src) meta (make-lambda-case src req #f rest #f '() vars exp #f)))) (build-case-lambda - (lambda (src meta body) (make-lambda src meta body))) + (lambda (src meta body) (make-lambda (sourcev->alist src) meta body))) (build-lambda-case (lambda (src req opt rest kw inits vars body else-case) - (make-lambda-case src req opt rest kw inits vars body else-case))) + (make-lambda-case + (sourcev->alist src) + req + opt + rest + kw + inits + vars + body + else-case))) (build-primcall - (lambda (src name args) (make-primcall src name args))) - (build-primref (lambda (src name) (make-primitive-ref src name))) - (build-data (lambda (src exp) (make-const src exp))) + (lambda (src name args) + (make-primcall (sourcev->alist src) name args))) + (build-primref + (lambda (src name) (make-primitive-ref (sourcev->alist src) name))) + (build-data (lambda (src exp) (make-const (sourcev->alist src) exp))) (build-sequence (lambda (src exps) (if (null? (cdr exps)) (car exps) - (make-seq src (car exps) (build-sequence #f (cdr exps)))))) + (make-seq + (sourcev->alist src) + (car exps) + (build-sequence #f (cdr exps)))))) (build-let (lambda (src ids vars val-exps body-exp) (for-each maybe-name-value! ids val-exps) - (if (null? vars) body-exp (make-let src ids vars val-exps body-exp)))) + (if (null? vars) + body-exp + (make-let (sourcev->alist src) ids vars val-exps body-exp)))) (build-named-let (lambda (src ids vars val-exps body-exp) (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids))) @@ -221,7 +263,7 @@ (maybe-name-value! f-name proc) (for-each maybe-name-value! ids val-exps) (make-letrec - src + (sourcev->alist src) #f (list f-name) (list f) @@ -233,11 +275,23 @@ body-exp (begin (for-each maybe-name-value! ids val-exps) - (make-letrec src in-order? ids vars val-exps body-exp))))) + (make-letrec + (sourcev->alist src) + in-order? + ids + vars + val-exps + body-exp))))) + (datum-sourcev + (lambda (datum) + (let ((props (source-properties datum))) + (and (pair? props) + (vector + (assq-ref props 'filename) + (assq-ref props 'line) + (assq-ref props 'column)))))) (source-annotation - (lambda (x) - (let ((props (source-properties (if (syntax? x) (syntax-expression x) x)))) - (and (pair? props) props)))) + (lambda (x) (if (syntax? x) (syntax-sourcev x) (datum-sourcev x)))) (extend-env (lambda (labels bindings r) (if (null? labels) @@ -383,7 +437,7 @@ ((syntax? id) (let ((id (syntax-expression id)) (w1 (syntax-wrap id)) - (mod (syntax-module id))) + (mod (or (syntax-module id) mod))) (let ((marks (join-marks (car w) (car w1)))) (call-with-values (lambda () (search id (cdr w) marks mod)) @@ -465,12 +519,12 @@ (syntax-expression n) (syntax-wrap n) r - (syntax-module n) + (or (syntax-module n) mod) resolve-syntax-parameters?))) ((symbol? n) - (resolve-global n (if (syntax? id) (syntax-module id) mod))) + (resolve-global n (or (and (syntax? id) (syntax-module id)) mod))) ((string? n) - (resolve-lexical n (if (syntax? id) (syntax-module id) mod))) + (resolve-lexical n (or (and (syntax? id) (syntax-module id)) mod))) (else (error "unexpected id-var-name" id w n))))))) (transformer-environment (make-fluid @@ -521,17 +575,20 @@ (lambda (x list) (and (not (null? list)) (or (bound-id=? x (car list)) (bound-id-member? x (cdr list)))))) - (wrap (lambda (x w defmod) - (cond ((and (null? (car w)) (null? (cdr w))) x) - ((syntax? x) - (make-syntax - (syntax-expression x) - (join-wraps w (syntax-wrap x)) - (syntax-module x))) - ((null? x) x) - (else (make-syntax x w defmod))))) + (wrap (lambda (x w defmod) (source-wrap x w #f defmod))) + (wrap-syntax + (lambda (x w defmod) + (make-syntax + (syntax-expression x) + w + (or (syntax-module x) defmod) + (syntax-sourcev x)))) (source-wrap - (lambda (x w s defmod) (wrap (decorate-source x s) w defmod))) + (lambda (x w s defmod) + (cond ((and (null? (car w)) (null? (cdr w)) (not defmod) (not s)) x) + ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod)) + ((null? x) x) + (else (make-syntax x w defmod (or s (datum-sourcev x))))))) (expand-sequence (lambda (body r w s mod) (build-sequence @@ -553,7 +610,7 @@ (extend-ribcage! ribcage id - (cons (syntax-module id) (wrap var '((top)) mod)))))) + (cons (or (syntax-module id) mod) (wrap var '((top)) mod)))))) (macro-introduced-identifier? (lambda (id) (not (equal? (car (syntax-wrap id)) '(top))))) (fresh-derived-name @@ -710,7 +767,7 @@ e))))) (parse-when-list (lambda (e when-list) - (let ((result (strip when-list '(())))) + (let ((result (strip when-list))) (let lp ((l result)) (cond ((null? l) result) ((memq (car l) '(compile load eval expand)) (lp (cdr l))) @@ -745,7 +802,7 @@ ((memv key '(global)) (if (equal? fmod '(primitive)) (values 'primitive-call fval e e w s mod) - (values 'global-call (make-syntax fval w fmod) e e w s mod))) + (values 'global-call (make-syntax fval w fmod fs) e e w s mod))) ((memv key '(macro)) (syntax-type (expand-macro fval e r w s rib mod) @@ -867,7 +924,7 @@ (build-global-reference (or (source-annotation (car e)) s) (if (syntax? value) (syntax-expression value) value) - (if (syntax? value) (syntax-module value) mod)) + (or (and (syntax? value) (syntax-module value)) mod)) e r w @@ -883,8 +940,7 @@ #f "source expression failed to match any pattern" tmp-1)))) - ((memv key '(constant)) - (build-data s (strip (source-wrap e w s mod) '(())))) + ((memv key '(constant)) (build-data s (strip e))) ((memv key '(global)) (build-global-reference s value mod)) ((memv key '(call)) (expand-call (expand (car e) r w mod) e r w s mod)) @@ -963,15 +1019,15 @@ (let ((w (syntax-wrap x))) (let ((ms (car w)) (ss (cdr w))) (if (and (pair? ms) (eq? (car ms) #f)) - (make-syntax - (syntax-expression x) + (wrap-syntax + x (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))) - (syntax-module x)) - (make-syntax - (decorate-source (syntax-expression x) s) + mod) + (wrap-syntax + x (cons (cons m ms) (if rib (cons rib (cons 'shift ss)) (cons 'shift ss))) - (syntax-module x)))))) + mod))))) ((vector? x) (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s))) (let loop ((i 0)) @@ -987,11 +1043,11 @@ (source-wrap e w (cdr w) mod) x)) (else (decorate-source x s)))))) - (let* ((t-680b775fb37a463-d6f transformer-environment) - (t-680b775fb37a463-d70 (lambda (k) (k e r w s rib mod)))) + (let* ((t-680b775fb37a463-dd8 transformer-environment) + (t-680b775fb37a463-dd9 (lambda (k) (k e r w s rib mod)))) (with-fluid* - t-680b775fb37a463-d6f - t-680b775fb37a463-d70 + t-680b775fb37a463-dd8 + t-680b775fb37a463-dd9 (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) @@ -1027,13 +1083,15 @@ (lp (cdr var-ids) (cdr vars) (cdr vals) - (make-seq src ((car vals)) tail))) + (make-seq (sourcev->alist src) ((car vals)) tail))) (else (let ((var-ids (map (lambda (id) (if id (syntax->datum id) '_)) (reverse var-ids))) (vars (map (lambda (var) (or var (gen-label))) (reverse vars))) (vals (map (lambda (expand-expr id) - (if id (expand-expr) (make-seq src (expand-expr) (build-void src)))) + (if id + (expand-expr) + (make-seq (sourcev->alist src) (expand-expr) (build-void src)))) (reverse vals) (reverse var-ids)))) (build-letrec src #t var-ids vars vals tail))))))) @@ -1181,7 +1239,11 @@ (call-with-values (lambda () (resolve-identifier - (make-syntax '#{ $sc-ellipsis }# (syntax-wrap e) (syntax-module e)) + (make-syntax + '#{ $sc-ellipsis }# + (syntax-wrap e) + (or (syntax-module e) mod) + #f) '(()) r mod @@ -1554,11 +1616,11 @@ s mod get-formals - (map (lambda (tmp-680b775fb37a463-fe0 - tmp-680b775fb37a463-fdf - tmp-680b775fb37a463-fde) - (cons tmp-680b775fb37a463-fde - (cons tmp-680b775fb37a463-fdf tmp-680b775fb37a463-fe0))) + (map (lambda (tmp-680b775fb37a463-104d + tmp-680b775fb37a463-104c + tmp-680b775fb37a463-104b) + (cons tmp-680b775fb37a463-104b + (cons tmp-680b775fb37a463-104c tmp-680b775fb37a463-104d))) e2* e1* args*))) @@ -1571,21 +1633,15 @@ #f "source expression failed to match any pattern" tmp)))))))) - (strip (lambda (x w) - (if (memq 'top (car w)) - x - (let f ((x x)) - (cond ((syntax? x) (strip (syntax-expression x) (syntax-wrap x))) - ((pair? x) - (let ((a (f (car x))) (d (f (cdr x)))) - (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d)))) - ((vector? x) - (let* ((old (vector->list x)) (new (map f old))) - (let lp ((l1 old) (l2 new)) - (cond ((null? l1) x) - ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2))) - (else (list->vector new)))))) - (else x)))))) + (strip (lambda (x) + (letrec* + ((annotate (lambda (proc datum) (decorate-source datum (proc x))))) + (cond ((syntax? x) (annotate syntax-sourcev (strip (syntax-expression x)))) + ((pair? x) + (annotate datum-sourcev (cons (strip (car x)) (strip (cdr x))))) + ((vector? x) + (annotate datum-sourcev (list->vector (strip (vector->list x))))) + (else x))))) (gen-var (lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) @@ -1651,10 +1707,18 @@ (lambda (e r w s mod) (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any)))) (if tmp - (apply (lambda (e) (build-data s (strip e w))) tmp) + (apply (lambda (e) (build-data s (strip e))) tmp) (syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) (global-extend 'core + 'quote-syntax + (lambda (e r w s mod) + (let* ((tmp-1 (source-wrap e w s mod)) (tmp ($sc-dispatch tmp-1 '(_ any)))) + (if tmp + (apply (lambda (e) (build-data s e)) tmp) + (let ((e tmp-1)) (syntax-violation 'quote "bad syntax" e)))))) + (global-extend + 'core 'syntax (letrec* ((gen-syntax @@ -1715,14 +1779,17 @@ (lambda () (gen-syntax src y r maps ellipsis? mod)) (lambda (y maps) (values (gen-cons x y) maps)))))) tmp-1) - (let ((tmp ($sc-dispatch tmp '#(vector (any . each-any))))) - (if tmp + (let ((tmp-1 ($sc-dispatch tmp '#(vector (any . each-any))))) + (if tmp-1 (apply (lambda (e1 e2) (call-with-values (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod)) (lambda (e maps) (values (gen-vector e) maps)))) - tmp) - (values (list 'quote e) maps)))))))))))) + tmp-1) + (let ((tmp ($sc-dispatch tmp '()))) + (if tmp + (apply (lambda () (values ''() maps)) tmp) + (values (list 'quote e) maps)))))))))))))) (gen-ref (lambda (src var level maps) (cond ((= level 0) (values var maps)) @@ -1856,11 +1923,11 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-69c - tmp-680b775fb37a463-69b - tmp-680b775fb37a463-69a) - (cons tmp-680b775fb37a463-69a - (cons tmp-680b775fb37a463-69b tmp-680b775fb37a463-69c))) + (map (lambda (tmp-680b775fb37a463-6b2 + tmp-680b775fb37a463-6b1 + tmp-680b775fb37a463-6b0) + (cons tmp-680b775fb37a463-6b0 + (cons tmp-680b775fb37a463-6b1 tmp-680b775fb37a463-6b2))) e2 e1 args))) @@ -1872,11 +1939,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-6b2 - tmp-680b775fb37a463-6b1 - tmp-680b775fb37a463-6b0) - (cons tmp-680b775fb37a463-6b0 - (cons tmp-680b775fb37a463-6b1 tmp-680b775fb37a463-6b2))) + (map (lambda (tmp-680b775fb37a463-6c8 + tmp-680b775fb37a463-6c7 + tmp-680b775fb37a463-6c6) + (cons tmp-680b775fb37a463-6c6 + (cons tmp-680b775fb37a463-6c7 tmp-680b775fb37a463-6c8))) e2 e1 args))) @@ -1899,9 +1966,11 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (cons tmp-680b775fb37a463 - (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) + (map (lambda (tmp-680b775fb37a463-67c + tmp-680b775fb37a463-67b + tmp-680b775fb37a463-67a) + (cons tmp-680b775fb37a463-67a + (cons tmp-680b775fb37a463-67b tmp-680b775fb37a463-67c))) e2 e1 args))) @@ -1913,11 +1982,9 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-67c - tmp-680b775fb37a463-67b - tmp-680b775fb37a463-67a) - (cons tmp-680b775fb37a463-67a - (cons tmp-680b775fb37a463-67b tmp-680b775fb37a463-67c))) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (cons tmp-680b775fb37a463 + (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) e2 e1 args))) @@ -1935,7 +2002,8 @@ (make-syntax '#{ $sc-ellipsis }# (syntax-wrap dots) - (syntax-module dots))))) + (syntax-module dots) + (syntax-sourcev dots))))) (let ((ids (list id)) (labels (list (gen-label))) (bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) @@ -2117,7 +2185,8 @@ (make-syntax (remodulate (syntax-expression x) mod) (syntax-wrap x) - mod)) + mod + (syntax-sourcev x))) ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (let loop ((i 0)) @@ -2136,7 +2205,9 @@ (if (and tmp-1 (apply (lambda (id) (and (id? id) - (equal? (cdr (if (syntax? id) (syntax-module id) mod)) '(guile)))) + (equal? + (cdr (or (and (syntax? id) (syntax-module id)) mod)) + '(guile)))) tmp-1)) (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive))) tmp-1) @@ -2269,7 +2340,7 @@ (lambda () (cvt x n ids)) (lambda (p ids) (values (vector 'vector p) ids)))) tmp-1) - (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids)))))))))))))))) + (let ((x tmp)) (values (vector 'atom (strip p)) ids)))))))))))))))) (cvt pattern 0 '())))) (build-dispatch-call (lambda (pvars exp y r mod) @@ -2413,10 +2484,16 @@ (cons 'hygiene (module-name (current-module)))))) (set! identifier? (lambda (x) (nonsymbol-id? x))) (set! datum->syntax - (lambda (id datum) - (make-syntax datum (syntax-wrap id) (syntax-module id)))) - (set! syntax->datum (lambda (x) (strip x '(())))) - (set! syntax-source (lambda (x) (source-annotation x))) + (lambda* (id datum #:key (source #f #:source)) + (make-syntax + datum + (if id (syntax-wrap id) '(())) + (and id (syntax-module id)) + (cond ((not source) (datum-sourcev datum)) + ((and (list? source) (and-map pair? source)) source) + ((and (vector? source) (= 3 (vector-length source))) source) + (else (syntax-sourcev source)))))) + (set! syntax->datum (lambda (x) (strip x))) (set! generate-temporaries (lambda (ls) (let ((x ls)) @@ -2454,8 +2531,8 @@ who message (or (source-annotation subform) (source-annotation form)) - (strip form '(())) - (and subform (strip subform '(())))))) + (strip form) + (strip subform)))) (letrec* ((%syntax-module (lambda (id) @@ -2463,7 +2540,7 @@ (if (not (nonsymbol-id? x)) (syntax-violation 'syntax-module "invalid argument" x))) (let ((mod (syntax-module id))) - (and (not (equal? mod '(primitive))) (cdr mod))))) + (and mod (not (equal? mod '(primitive))) (cdr mod))))) (syntax-local-binding (lambda* (id #:key @@ -2486,7 +2563,7 @@ (syntax-expression id) (strip-anti-mark (syntax-wrap id)) r - (syntax-module id) + (or (syntax-module id) mod) resolve-syntax-parameters?)) (lambda (type value mod) (let ((key type)) @@ -2502,10 +2579,7 @@ ((memv key '(ellipsis)) (values 'ellipsis - (make-syntax - (syntax-expression value) - (anti-mark (syntax-wrap value)) - (syntax-module value)))) + (wrap-syntax value (anti-mark (syntax-wrap value)) mod))) (else (values 'other #f))))))))))) (syntax-locally-bound-identifiers (lambda (id) @@ -2535,7 +2609,7 @@ (syntax-expression e) p (join-wraps w (syntax-wrap e)) - (syntax-module e))) + (or (syntax-module e) mod))) (else #f)))) (match-each+ (lambda (e x-pat y-pat z-pat w r mod) @@ -2620,7 +2694,7 @@ (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r)))))) ((memv key '(free-id)) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) - ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r)) + ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e)) r)) ((memv key '(vector)) (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod))))))))) (match (lambda (e p w r mod) @@ -2633,7 +2707,7 @@ p (join-wraps w (syntax-wrap e)) r - (syntax-module e))) + (or (syntax-module e) mod))) (else (match* e p w r mod)))))) (set! $sc-dispatch (lambda (e p) @@ -2823,11 +2897,9 @@ #f k '() - (map (lambda (tmp-680b775fb37a463-110d - tmp-680b775fb37a463-110c - tmp-680b775fb37a463-110b) - (list (cons tmp-680b775fb37a463-110b tmp-680b775fb37a463-110c) - tmp-680b775fb37a463-110d)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2843,9 +2915,9 @@ #f k (list docstring) - (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) - tmp-680b775fb37a463-2)) + (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-117f) + (list (cons tmp-680b775fb37a463-117f tmp-680b775fb37a463) + tmp-680b775fb37a463-1)) template pattern keyword))) @@ -2860,11 +2932,9 @@ dots k '() - (map (lambda (tmp-680b775fb37a463-113f - tmp-680b775fb37a463-113e - tmp-680b775fb37a463-113d) - (list (cons tmp-680b775fb37a463-113d tmp-680b775fb37a463-113e) - tmp-680b775fb37a463-113f)) + (map (lambda (tmp-680b775fb37a463-119a tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-119a)) template pattern keyword))) @@ -2880,11 +2950,11 @@ dots k (list docstring) - (map (lambda (tmp-680b775fb37a463-115e - tmp-680b775fb37a463-115d - tmp-680b775fb37a463-115c) - (list (cons tmp-680b775fb37a463-115c tmp-680b775fb37a463-115d) - tmp-680b775fb37a463-115e)) + (map (lambda (tmp-680b775fb37a463-11b9 + tmp-680b775fb37a463-11b8 + tmp-680b775fb37a463-11b7) + (list (cons tmp-680b775fb37a463-11b7 tmp-680b775fb37a463-11b8) + tmp-680b775fb37a463-11b9)) template pattern keyword))) @@ -3032,8 +3102,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-120e) - (list "value" tmp-680b775fb37a463-120e)) + (map (lambda (tmp-680b775fb37a463) + (list "value" tmp-680b775fb37a463)) p) (quasi q lev)) (quasicons @@ -3056,8 +3126,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463) - (list "value" tmp-680b775fb37a463)) + (map (lambda (tmp-680b775fb37a463-126e) + (list "value" tmp-680b775fb37a463-126e)) p) (quasi q lev)) (quasicons @@ -3110,8 +3180,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-122e) - (list "value" tmp-680b775fb37a463-122e)) + (map (lambda (tmp-680b775fb37a463) + (list "value" tmp-680b775fb37a463)) p) (vquasi q lev)) (quasicons @@ -3201,7 +3271,8 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463)) + (apply (lambda (t-680b775fb37a463-12d2) + (cons "vector" t-680b775fb37a463-12d2)) tmp) (syntax-violation #f @@ -3211,7 +3282,8 @@ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (if tmp-1 (apply (lambda (y) - (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463)) + (k (map (lambda (tmp-680b775fb37a463-12de) + (list "quote" tmp-680b775fb37a463-12de)) y))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) @@ -3222,8 +3294,8 @@ (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (let ((else tmp)) (let ((tmp x)) - (let ((t-680b775fb37a463 tmp)) - (list "list->vector" t-680b775fb37a463))))))))))))))))) + (let ((t-680b775fb37a463-12ed tmp)) + (list "list->vector" t-680b775fb37a463-12ed))))))))))))))))) (emit (lambda (x) (let ((tmp x)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) @@ -3236,9 +3308,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12a1) + (apply (lambda (t-680b775fb37a463-12fc) (cons (make-syntax 'list '((top)) '(hygiene guile)) - t-680b775fb37a463-12a1)) + t-680b775fb37a463-12fc)) tmp) (syntax-violation #f @@ -3254,10 +3326,10 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-680b775fb37a463-12b5 t-680b775fb37a463-12b4) + (apply (lambda (t-680b775fb37a463 t-680b775fb37a463-130f) (list (make-syntax 'cons '((top)) '(hygiene guile)) - t-680b775fb37a463-12b5 - t-680b775fb37a463-12b4)) + t-680b775fb37a463 + t-680b775fb37a463-130f)) tmp) (syntax-violation #f @@ -3270,9 +3342,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12c1) + (apply (lambda (t-680b775fb37a463-131c) (cons (make-syntax 'append '((top)) '(hygiene guile)) - t-680b775fb37a463-12c1)) + t-680b775fb37a463-131c)) tmp) (syntax-violation #f @@ -3285,9 +3357,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12cd) + (apply (lambda (t-680b775fb37a463) (cons (make-syntax 'vector '((top)) '(hygiene guile)) - t-680b775fb37a463-12cd)) + t-680b775fb37a463)) tmp) (syntax-violation #f @@ -3298,9 +3370,9 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t-680b775fb37a463-12d9 tmp)) + (let ((t-680b775fb37a463 tmp)) (list (make-syntax 'list->vector '((top)) '(hygiene guile)) - t-680b775fb37a463-12d9)))) + t-680b775fb37a463)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (if tmp-1 @@ -3356,7 +3428,7 @@ (lambda (p) (cons (make-syntax 'begin '((top)) '(hygiene guile)) (let lp () - (let ((x (read p))) + (let ((x (read-syntax p))) (if (eof-object? x) '() (cons (datum->syntax filename x) (lp))))))))) tmp) (syntax-violation diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index b11771aa0..b52bb397e 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1,6 +1,6 @@ ;;;; -*-scheme-*- ;;;; -;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2020 +;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2021 ;;;; Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -98,33 +98,6 @@ ;;; compiled. In this way, psyntax bootstraps off of an expanded ;;; version of itself. -;;; This implementation of the expander sometimes uses syntactic -;;; abstractions when procedural abstractions would suffice. For -;;; example, we define top-wrap and top-marked? as -;;; -;;; (define-syntax top-wrap (identifier-syntax '((top)))) -;;; (define-syntax top-marked? -;;; (syntax-rules () -;;; ((_ w) (memq 'top (wrap-marks w))))) -;;; -;;; rather than -;;; -;;; (define top-wrap '((top))) -;;; (define top-marked? -;;; (lambda (w) (memq 'top (wrap-marks w)))) -;;; -;;; On the other hand, we don't do this consistently; we define -;;; make-wrap, wrap-marks, and wrap-subst simply as -;;; -;;; (define make-wrap cons) -;;; (define wrap-marks car) -;;; (define wrap-subst cdr) -;;; -;;; In Chez Scheme, the syntactic and procedural forms of these -;;; abstractions are equivalent, since the optimizer consistently -;;; integrates constants and small procedures. This will be true of -;;; Guile as well, once we implement a proper inliner. - ;;; Implementation notes: @@ -169,7 +142,8 @@ (make-syntax (module-ref (current-module) 'make-syntax)) (syntax-expression (module-ref (current-module) 'syntax-expression)) (syntax-wrap (module-ref (current-module) 'syntax-wrap)) - (syntax-module (module-ref (current-module) 'syntax-module))) + (syntax-module (module-ref (current-module) 'syntax-module)) + (syntax-sourcev (module-ref (current-module) 'syntax-sourcev))) (define-syntax define-expansion-constructors (lambda (x) @@ -294,9 +268,19 @@ (lambda () ((variable-ref v)))))) + (define (sourcev-filename s) (vector-ref s 0)) + (define (sourcev-line s) (vector-ref s 1)) + (define (sourcev-column s) (vector-ref s 2)) + (define (sourcev->alist sourcev) + (define (maybe-acons k v tail) (if v (acons k v tail) tail)) + (and sourcev + (maybe-acons 'filename (sourcev-filename sourcev) + `((line . ,(sourcev-line sourcev)) + (column . ,(sourcev-column sourcev)))))) + (define (decorate-source e s) - (if (and s (supports-source-properties? e)) - (set-source-properties! e s)) + (when (and s (supports-source-properties? e)) + (set-source-properties! e (sourcev->alist s))) e) (define (maybe-name-value! name val) @@ -307,25 +291,25 @@ ;; output constructors (define build-void - (lambda (source) - (make-void source))) + (lambda (sourcev) + (make-void (sourcev->alist sourcev)))) (define build-call - (lambda (source fun-exp arg-exps) - (make-call source fun-exp arg-exps))) + (lambda (sourcev fun-exp arg-exps) + (make-call (sourcev->alist sourcev) fun-exp arg-exps))) (define build-conditional - (lambda (source test-exp then-exp else-exp) - (make-conditional source test-exp then-exp else-exp))) + (lambda (sourcev test-exp then-exp else-exp) + (make-conditional (sourcev->alist sourcev) test-exp then-exp else-exp))) (define build-lexical-reference - (lambda (type source name var) - (make-lexical-ref source name var))) + (lambda (type sourcev name var) + (make-lexical-ref (sourcev->alist sourcev) name var))) (define build-lexical-assignment - (lambda (source name var exp) + (lambda (sourcev name var exp) (maybe-name-value! name exp) - (make-lexical-set source name var exp))) + (make-lexical-set (sourcev->alist sourcev) name var exp))) (define (analyze-variable mod var modref-cont bare-cont) (if (not mod) @@ -347,32 +331,32 @@ (else (syntax-violation #f "bad module kind" var mod)))))) (define build-global-reference - (lambda (source var mod) + (lambda (sourcev var mod) (analyze-variable mod var (lambda (mod var public?) - (make-module-ref source mod var public?)) + (make-module-ref (sourcev->alist sourcev) mod var public?)) (lambda (mod var) - (make-toplevel-ref source mod var))))) + (make-toplevel-ref (sourcev->alist sourcev) mod var))))) (define build-global-assignment - (lambda (source var exp mod) + (lambda (sourcev var exp mod) (maybe-name-value! var exp) (analyze-variable mod var (lambda (mod var public?) - (make-module-set source mod var public? exp)) + (make-module-set (sourcev->alist sourcev) mod var public? exp)) (lambda (mod var) - (make-toplevel-set source mod var exp))))) + (make-toplevel-set (sourcev->alist sourcev) mod var exp))))) (define build-global-definition - (lambda (source mod var exp) + (lambda (sourcev mod var exp) (maybe-name-value! var exp) - (make-toplevel-define source (and mod (cdr mod)) var exp))) + (make-toplevel-define (sourcev->alist sourcev) (and mod (cdr mod)) var exp))) (define build-simple-lambda (lambda (src req rest vars meta exp) - (make-lambda src + (make-lambda (sourcev->alist src) meta ;; hah, a case in which kwargs would be nice. (make-lambda-case @@ -381,7 +365,7 @@ (define build-case-lambda (lambda (src meta body) - (make-lambda src meta body))) + (make-lambda (sourcev->alist src) meta body))) (define build-lambda-case ;; req := (name ...) @@ -395,31 +379,31 @@ ;; the body of a lambda: anything, already expanded ;; else: lambda-case | #f (lambda (src req opt rest kw inits vars body else-case) - (make-lambda-case src req opt rest kw inits vars body else-case))) + (make-lambda-case (sourcev->alist src) req opt rest kw inits vars body else-case))) (define build-primcall (lambda (src name args) - (make-primcall src name args))) + (make-primcall (sourcev->alist src) name args))) (define build-primref (lambda (src name) - (make-primitive-ref src name))) + (make-primitive-ref (sourcev->alist src) name))) (define (build-data src exp) - (make-const src exp)) + (make-const (sourcev->alist src) exp)) (define build-sequence (lambda (src exps) (if (null? (cdr exps)) (car exps) - (make-seq src (car exps) (build-sequence #f (cdr exps)))))) + (make-seq (sourcev->alist src) (car exps) (build-sequence #f (cdr exps)))))) (define build-let (lambda (src ids vars val-exps body-exp) (for-each maybe-name-value! ids val-exps) (if (null? vars) body-exp - (make-let src ids vars val-exps body-exp)))) + (make-let (sourcev->alist src) ids vars val-exps body-exp)))) (define build-named-let (lambda (src ids vars val-exps body-exp) @@ -431,7 +415,7 @@ (maybe-name-value! f-name proc) (for-each maybe-name-value! ids val-exps) (make-letrec - src #f + (sourcev->alist src) #f (list f-name) (list f) (list proc) (build-call src (build-lexical-reference 'fun src f-name f) val-exps)))))) @@ -442,7 +426,7 @@ body-exp (begin (for-each maybe-name-value! ids val-exps) - (make-letrec src in-order? ids vars val-exps body-exp))))) + (make-letrec (sourcev->alist src) in-order? ids vars val-exps body-exp))))) (define-syntax-rule (build-lexical-var src id) @@ -452,13 +436,18 @@ (define-syntax no-source (identifier-syntax #f)) + (define (datum-sourcev datum) + (let ((props (source-properties datum))) + (and (pair? props) + (vector (assq-ref props 'filename) + (assq-ref props 'line) + (assq-ref props 'column))))) + (define source-annotation (lambda (x) - (let ((props (source-properties - (if (syntax? x) - (syntax-expression x) - x)))) - (and (pair? props) props)))) + (if (syntax? x) + (syntax-sourcev x) + (datum-sourcev x)))) (define-syntax-rule (arg-check pred? e who) (let ((x e)) @@ -627,12 +616,8 @@ (define-structure (ribcage symnames marks labels)) (define-syntax empty-wrap (identifier-syntax '(()))) - (define-syntax top-wrap (identifier-syntax '((top)))) - (define-syntax-rule (top-marked? w) - (memq 'top (wrap-marks w))) - ;; Marks must be comparable with "eq?" and distinct from pairs and ;; the symbol top. We do not use integers so that marks will remain ;; unique even across file compiles. @@ -792,7 +777,7 @@ ((syntax? id) (let ((id (syntax-expression id)) (w1 (syntax-wrap id)) - (mod (syntax-module id))) + (mod (or (syntax-module id) mod))) (let ((marks (join-marks (wrap-marks w) (wrap-marks w1)))) (call-with-values (lambda () (search id (wrap-subst w) marks mod)) (lambda (new-id marks) @@ -934,15 +919,15 @@ (resolve-identifier (syntax-expression n) (syntax-wrap n) r - (syntax-module n) + (or (syntax-module n) mod) resolve-syntax-parameters?)))) ((symbol? n) - (resolve-global n (if (syntax? id) - (syntax-module id) + (resolve-global n (or (and (syntax? id) + (syntax-module id)) mod))) ((string? n) - (resolve-lexical n (if (syntax? id) - (syntax-module id) + (resolve-lexical n (or (and (syntax? id) + (syntax-module id)) mod))) (else (error "unexpected id-var-name" id w n))))) @@ -1042,19 +1027,23 @@ (define wrap (lambda (x w defmod) - (cond - ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x) - ((syntax? x) - (make-syntax - (syntax-expression x) - (join-wraps w (syntax-wrap x)) - (syntax-module x))) - ((null? x) x) - (else (make-syntax x w defmod))))) - - (define source-wrap - (lambda (x w s defmod) - (wrap (decorate-source x s) w defmod))) + (source-wrap x w #f defmod))) + + (define (wrap-syntax x w defmod) + (make-syntax (syntax-expression x) + w + (or (syntax-module x) defmod) + (syntax-sourcev x))) + (define (source-wrap x w s defmod) + (cond + ((and (null? (wrap-marks w)) + (null? (wrap-subst w)) + (not defmod) + (not s)) + x) + ((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod)) + ((null? x) x) + (else (make-syntax x w defmod (or s (datum-sourcev x)))))) ;; expanding @@ -1095,7 +1084,7 @@ ;; the special case of names that are pairs. See the ;; comments in id-var-name for more. (extend-ribcage! ribcage id - (cons (syntax-module id) + (cons (or (syntax-module id) mod) (wrap var top-wrap mod))))) (define (macro-introduced-identifier? id) (not (equal? (wrap-marks (syntax-wrap id)) '(top)))) @@ -1266,7 +1255,7 @@ ;; we twingle the definition of eval-when to the bindings of ;; eval, load, expand, and compile, which is totally unintended. ;; So do a symbolic match instead. - (let ((result (strip when-list empty-wrap))) + (let ((result (strip when-list))) (let lp ((l result)) (if (null? l) result @@ -1348,7 +1337,7 @@ ;; need to make sure the fmod information is ;; propagated back correctly -- hence this ;; consing. - (values 'global-call (make-syntax fval w fmod) + (values 'global-call (make-syntax fval w fmod fs) e e w s mod))) ((macro) (syntax-type (expand-macro fval e r w s rib mod) @@ -1441,8 +1430,8 @@ (if (syntax? value) (syntax-expression value) value) - (if (syntax? value) - (syntax-module value) + (or (and (syntax? value) + (syntax-module value)) mod)) e r w s mod)) ((primitive-call) @@ -1452,7 +1441,7 @@ value (map (lambda (e) (expand e r w mod)) #'(e ...)))))) - ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap))) + ((constant) (build-data s (strip e))) ((global) (build-global-reference s value mod)) ((call) (expand-call (expand (car e) r w mod) e r w s mod)) ((begin-form) @@ -1536,18 +1525,21 @@ (let ((ms (wrap-marks w)) (ss (wrap-subst w))) (if (and (pair? ms) (eq? (car ms) the-anti-mark)) ;; output is from original text - (make-syntax - (syntax-expression x) - (make-wrap (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))) - (syntax-module x)) + (wrap-syntax + x + (make-wrap (cdr ms) + (if rib + (cons rib (cdr ss)) + (cdr ss))) + mod) ;; output introduced by macro - (make-syntax - (decorate-source (syntax-expression x) s) + (wrap-syntax + x (make-wrap (cons m ms) (if rib (cons rib (cons 'shift ss)) (cons 'shift ss))) - (syntax-module x)))))) + mod))))) ((vector? x) (let* ((n (vector-length x)) @@ -1630,7 +1622,7 @@ ((null? var-ids) tail) ((not (car var-ids)) (lp (cdr var-ids) (cdr vars) (cdr vals) - (make-seq src ((car vals)) tail))) + (make-seq (sourcev->alist src) ((car vals)) tail))) (else (let ((var-ids (map (lambda (id) (if id (syntax->datum id) '_)) @@ -1640,7 +1632,8 @@ (vals (map (lambda (expand-expr id) (if id (expand-expr) - (make-seq src (expand-expr) + (make-seq (sourcev->alist src) + (expand-expr) (build-void src)))) (reverse vals) (reverse var-ids)))) (build-letrec src #t var-ids vars vals tail))))))) @@ -1781,8 +1774,9 @@ (call-with-values (lambda () (resolve-identifier (make-syntax '#{ $sc-ellipsis }# - (syntax-wrap e) - (syntax-module e)) + (syntax-wrap e) + (or (syntax-module e) mod) + #f) empty-wrap r mod #f)) (lambda (type value mod) (if (eq? type 'ellipsis) @@ -1998,36 +1992,19 @@ ;; data - ;; strips syntax objects down to top-wrap - ;; - ;; since only the head of a list is annotated by the reader, not each pair - ;; in the spine, we also check for pairs whose cars are annotated in case - ;; we've been passed the cdr of an annotated list + ;; strips syntax objects, recursively. - (define strip - (lambda (x w) - (if (top-marked? w) - x - (let f ((x x)) - (cond - ((syntax? x) - (strip (syntax-expression x) (syntax-wrap x))) - ((pair? x) - (let ((a (f (car x))) (d (f (cdr x)))) - (if (and (eq? a (car x)) (eq? d (cdr x))) - x - (cons a d)))) - ((vector? x) - (let ((old (vector->list x))) - (let ((new (map f old))) - ;; inlined and-map with two args - (let lp ((l1 old) (l2 new)) - (if (null? l1) - x - (if (eq? (car l1) (car l2)) - (lp (cdr l1) (cdr l2)) - (list->vector new))))))) - (else x)))))) + (define (strip x) + (define (annotate proc datum) + (decorate-source datum (proc x))) + (cond + ((syntax? x) + (annotate syntax-sourcev (strip (syntax-expression x)))) + ((pair? x) + (annotate datum-sourcev (cons (strip (car x)) (strip (cdr x))))) + ((vector? x) + (annotate datum-sourcev (list->vector (strip (vector->list x))))) + (else x))) ;; lexical variables @@ -2100,10 +2077,16 @@ (global-extend 'core 'quote (lambda (e r w s mod) (syntax-case e () - ((_ e) (build-data s (strip #'e w))) + ((_ e) (build-data s (strip #'e))) (_ (syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) + (global-extend 'core 'quote-syntax + (lambda (e r w s mod) + (syntax-case (source-wrap e w s mod) () + ((_ e) (build-data s #'e)) + (e (syntax-violation 'quote "bad syntax" #'e))))) + (global-extend 'core 'syntax (let () @@ -2174,6 +2157,7 @@ (lambda () (gen-syntax src #'(e1 e2 ...) r maps ellipsis? mod)) (lambda (e maps) (values (gen-vector e) maps)))) + (() (values '(quote ()) maps)) (_ (values `(quote ,e) maps)))))) (define gen-ref @@ -2344,8 +2328,9 @@ (let ((id (if (symbol? #'dots) '#{ $sc-ellipsis }# (make-syntax '#{ $sc-ellipsis }# - (syntax-wrap #'dots) - (syntax-module #'dots))))) + (syntax-wrap #'dots) + (syntax-module #'dots) + (syntax-sourcev #'dots))))) (let ((ids (list id)) (labels (list (gen-label))) (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod))))) @@ -2502,7 +2487,8 @@ (remodulate (syntax-expression x) mod) (syntax-wrap x) ;; hither the remodulation - mod)) + mod + (syntax-sourcev x))) ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (do ((i 0 (fx+ i 1))) @@ -2512,8 +2498,8 @@ (syntax-case e (@@ primitive) ((_ primitive id) (and (id? #'id) - (equal? (cdr (if (syntax? #'id) - (syntax-module #'id) + (equal? (cdr (or (and (syntax? #'id) + (syntax-module #'id)) mod)) '(guile))) ;; Strip the wrap from the identifier and return top-wrap @@ -2631,7 +2617,7 @@ (call-with-values (lambda () (cvt (syntax (x ...)) n ids)) (lambda (p ids) (values (vector 'vector p) ids)))) - (x (values (vector 'atom (strip p empty-wrap)) ids)))))) + (x (values (vector 'atom (strip p)) ids)))))) (cvt pattern 0 '()))) (define build-dispatch-call @@ -2759,18 +2745,26 @@ (nonsymbol-id? x))) (set! datum->syntax - (lambda (id datum) - (make-syntax datum (syntax-wrap id) - (syntax-module id)))) + (lambda* (id datum #:key source) + (make-syntax datum + (if id + (syntax-wrap id) + empty-wrap) + (if id + (syntax-module id) + #f) + (cond + ((not source) (datum-sourcev datum)) + ((and (list? source) (and-map pair? source)) source) + ((and (vector? source) (= 3 (vector-length source))) + source) + (else (syntax-sourcev source)))))) (set! syntax->datum ;; accepts any object, since syntax objects may consist partially ;; or entirely of unwrapped, nonsymbolic data (lambda (x) - (strip x empty-wrap))) - - (set! syntax-source - (lambda (x) (source-annotation x))) + (strip x))) (set! generate-temporaries (lambda (ls) @@ -2800,14 +2794,15 @@ (throw 'syntax-error who message (or (source-annotation subform) (source-annotation form)) - (strip form empty-wrap) - (and subform (strip subform empty-wrap))))) + (strip form) + (strip subform)))) (let () (define (%syntax-module id) (arg-check nonsymbol-id? id 'syntax-module) (let ((mod (syntax-module id))) - (and (not (equal? mod '(primitive))) + (and mod + (not (equal? mod '(primitive))) (cdr mod)))) (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t)) @@ -2826,7 +2821,7 @@ (syntax-expression id) (strip-anti-mark (syntax-wrap id)) r - (syntax-module id) + (or (syntax-module id) mod) resolve-syntax-parameters?)) (lambda (type value mod) (case type @@ -2841,9 +2836,8 @@ (values 'global (cons value (cdr mod))))) ((ellipsis) (values 'ellipsis - (make-syntax (syntax-expression value) - (anti-mark (syntax-wrap value)) - (syntax-module value)))) + (wrap-syntax value (anti-mark (syntax-wrap value)) + mod))) (else (values 'other #f)))))))) (define (syntax-locally-bound-identifiers id) @@ -2897,7 +2891,7 @@ (match-each (syntax-expression e) p (join-wraps w (syntax-wrap e)) - (syntax-module e))) + (or (syntax-module e) mod))) (else #f)))) (define match-each+ @@ -2993,7 +2987,7 @@ (match-empty (vector-ref p 1) r) (combine xr* r)))))) ((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) - ((atom) (and (equal? (vector-ref p 1) (strip e w)) r)) + ((atom) (and (equal? (vector-ref p 1) (strip e)) r)) ((vector) (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod)))))))) @@ -3010,7 +3004,7 @@ p (join-wraps w (syntax-wrap e)) r - (syntax-module e))) + (or (syntax-module e) mod))) (else (match* e p w r mod))))) (set! $sc-dispatch @@ -3273,7 +3267,7 @@ names." ;; In Guile, (cons #'a #'b) is the same as #'(a . b). (cons #'begin (let lp () - (let ((x (read p))) + (let ((x (read-syntax p))) (if (eof-object? x) #'() (cons (datum->syntax #'filename x) (lp)))))))))))) diff --git a/module/ice-9/read.scm b/module/ice-9/read.scm new file mode 100644 index 000000000..17215d8b1 --- /dev/null +++ b/module/ice-9/read.scm @@ -0,0 +1,880 @@ +;;; Scheme reader +;;; Copyright (C) 1995-1997,1999-2001,2003-2004,2006-2012,2014-2021 +;;; Free Software Foundation, Inc. +;;; +;;; This library is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; Implementation of Scheme's "read". +;;; +;;; Code: + + +;; While porting read.c to Scheme, I found these expressions that result +;; in undesirable behavior in the C reader. Most all of them are also +;; present in the Scheme reader. Probably I should fix all of them, but +;; I would first like to prove that the Scheme reader is good enough. +;; +;; (call-with-input-string "," read) +;; (read-disable 'square-brackets), then (call-with-input-string "]" read) +;; (call-with-input-string "(#tru1)" read) => '(#t ru1) +;; (call-with-input-string "(#true1)" read) => '(#t 1) +;; (call-with-input-string "(#fAlse)" read) => '(#f Alse) +;; (call-with-input-string "(#f1 #f2 #f3)" read) => error reading array +;; #: foo +;; #:#|what|#foo +;; #@-(1 2 3) => #(1 2 3) +;; (#*10101010102) => (#*1010101010 2) + +(define-syntax let*-values + (syntax-rules () + ((_ () . body) (let () . body)) + ((_ ((vars expr) . binds) . body) + (call-with-values (lambda () expr) + (lambda vars (let*-values binds . body)))))) + +(define bitfield:record-positions? 0) +(define bitfield:case-insensitive? 2) +(define bitfield:keyword-style 4) +(define bitfield:r6rs-escapes? 6) +(define bitfield:square-brackets? 8) +(define bitfield:hungry-eol-escapes? 10) +(define bitfield:curly-infix? 12) +(define bitfield:r7rs-symbols? 14) +(define read-option-bits 16) + +(define read-option-mask #b11) +(define read-option-inherit #b11) +(define read-options-inherit-all (1- (ash 1 read-option-bits))) + +(define keyword-style-hash-prefix 0) +(define keyword-style-prefix 1) +(define keyword-style-postfix 2) + +(define (compute-reader-options port) + (let ((options (read-options)) + (port-options (or (%port-property port 'port-read-options) + read-options-inherit-all))) + (define-syntax-rule (option field exp) + (let ((port-option (logand port-options (ash read-option-mask field)))) + (if (= port-option (ash read-option-inherit field)) + exp + port-option))) + (define (bool key field) + (option field + (if (memq key options) (ash 1 field) 0))) + (define (enum key values field) + (option field + (ash (assq-ref values (and=> (memq key options) cadr)) field))) + (logior (bool 'positions bitfield:record-positions?) + (bool 'case-insensitive bitfield:case-insensitive?) + (enum 'keywords '((#f . 0) (prefix . 1) (postfix . 2)) + bitfield:keyword-style) + (bool 'r6rs-hex-escapes bitfield:r6rs-escapes?) + (bool 'square-brackets bitfield:square-brackets?) + (bool 'hungry-eol-escapes bitfield:hungry-eol-escapes?) + (bool 'curly-infix bitfield:curly-infix?) + (bool 'r7rs-symbols bitfield:r7rs-symbols?)))) + +(define (set-option options field new) + (logior (ash new field) (logand options (lognot (ash #b11 field))))) + +(define (set-port-read-option! port field value) + (%set-port-property! port 'port-read-options + (set-option (or (%port-property port 'port-read-options) + read-options-inherit-all) + field value))) + +(define (%read port annotate strip-annotation) + ;; init read options + (define opts (compute-reader-options port)) + (define (enabled? field) + (not (zero? (logand (ash 1 field) opts)))) + (define (set-reader-option! field value) + (set! opts (set-option opts field value)) + (set-port-read-option! port field value)) + (define (case-insensitive?) (enabled? bitfield:case-insensitive?)) + (define (keyword-style) (logand read-option-mask + (ash opts (- bitfield:keyword-style)))) + (define (r6rs-escapes?) (enabled? bitfield:r6rs-escapes?)) + (define (square-brackets?) (enabled? bitfield:square-brackets?)) + (define (hungry-eol-escapes?) (enabled? bitfield:hungry-eol-escapes?)) + (define (curly-infix?) (enabled? bitfield:curly-infix?)) + (define (r7rs-symbols?) (enabled? bitfield:r7rs-symbols?)) + (define neoteric 0) + (define (next) (read-char port)) + (define (peek) (peek-char port)) + (define filename (port-filename port)) + (define (get-pos) (cons (port-line port) (port-column port))) + ;; We are only ever interested in whether an object is a char or not. + (define (eof-object? x) (not (char? x))) + + (define (input-error msg args) + (scm-error 'read-error #f + (format #f "~A:~S:~S: ~A" + (or filename "#<unknown port>") + (port-line port) (port-column port) + msg) + args #f)) + + (define-syntax-rule (error msg arg ...) + (let ((args (list arg ...))) + (input-error msg args))) + + (define (read-semicolon-comment) + (let ((ch (next))) + (cond + ((eof-object? ch) ch) + ((eqv? ch #\newline) (next)) + (else (read-semicolon-comment))))) + + (define-syntax-rule (take-until first pred) + (let lp ((out (list first))) + (let ((ch (peek))) + (if (or (eof-object? ch) (pred ch)) + (reverse-list->string out) + (begin + (next) + (lp (cons ch out))))))) + (define-syntax-rule (take-while first pred) + (take-until first (lambda (ch) (not (pred ch))))) + + (define (delimiter? ch) + (case ch + ((#\( #\) #\; #\" #\space #\return #\ff #\newline #\tab) #t) + ((#\[ #\]) (or (square-brackets?) (curly-infix?))) + ((#\{ #\}) (curly-infix?)) + (else #f))) + + (define (read-token ch) + (take-until ch delimiter?)) + + (define (read-mixed-case-symbol ch) + (let* ((str (read-token ch)) + (len (string-length str))) + (cond + ((and (eq? (keyword-style) keyword-style-postfix) + (> len 1) (eqv? #\: (string-ref str (1- len)))) + (let ((str (substring str 0 (1- len)))) + (symbol->keyword + (string->symbol + (if (case-insensitive?) + (string-downcase str) + str))))) + (else + (string->symbol + (if (case-insensitive?) + (string-downcase str) + str)))))) + + (define (read-parenthesized rdelim) + (define (finish-curly-infix ret) + ;; Perform syntactic transformations on {...} lists. + (define (extract-infix-list ls) + (and (pair? ls) + (let ((x (car ls)) + (ls (cdr ls))) + (and (pair? ls) + (let ((op (car ls)) + (ls (cdr ls))) + (if (and (pair? ls) (null? (cdr ls))) + (cons* op x ls) + (let ((tail (extract-infix-list ls))) + (and tail + (equal? (strip-annotation op) + (strip-annotation (car tail))) + (cons* op x (cdr tail)))))))))) + (cond + ((not (eqv? rdelim #\})) ret) ; Only on {...} lists. + ((not (pair? ret)) ret) ; {} => (); {.x} => x + ((null? (cdr ret)) (car ret)); {x} => x + ((and (pair? (cdr ret)) (null? (cddr ret))) ret) ; {x y} => (x y) + ((extract-infix-list ret)) ; {x + y + ... + z} => (+ x y ... z) + (else (cons '$nfx$ ret)))) ; {x y . z} => ($nfx$ x y . z) + (define curly? (eqv? rdelim #\})) + (finish-curly-infix + (let lp ((ch (next-non-whitespace))) + (when (eof-object? ch) + (error "unexpected end of input while searching for: ~A" + rdelim)) + (cond + ((eqv? ch rdelim) '()) + ((or (eqv? ch #\)) + (and (eqv? ch #\]) (or (square-brackets?) (curly-infix?))) + (and (eqv? ch #\}) (curly-infix?))) + (error "mismatched close paren: ~A" ch)) + (else + (let ((expr (read-expr ch))) + ;; Note that it is possible for scm_read_expression to + ;; return `.', but not as part of a dotted pair: as in + ;; #{.}#. Indeed an example is here! + (if (and (eqv? ch #\.) (eq? (strip-annotation expr) '#{.}#)) + (let* ((tail (read-subexpression "tail of improper list")) + (close (next-non-whitespace))) + (unless (eqv? close rdelim) + (error "missing close paren: ~A" close)) + tail) + (cons expr (lp (next-non-whitespace)))))))))) + + (define (hex-digit ch) + (case ch + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (- (char->integer ch) (char->integer #\0))) + ((#\a #\b #\c #\d #\e #\f) + (+ 10 (- (char->integer ch) (char->integer #\a)))) + ((#\A #\B #\C #\D #\E #\F) + (+ 10 (- (char->integer ch) (char->integer #\A)))) + (else #f))) + + (define (read-r6rs-hex-escape) + (let ((ch (next))) + (cond + ((hex-digit ch) => + (lambda (res) + (let lp ((res res)) + (let ((ch (next))) + (cond + ((hex-digit ch) => (lambda (digit) (lp (+ (* 16 res) digit)))) + ((eqv? ch #\;) (integer->char res)) + ((eof-object? ch) + (error "unexpected end of input in character escape sequence")) + (else + (error "invalid character in escape sequence: ~S" ch))))))) + ((eof-object? ch) + (error "unexpected end of input in character escape sequence")) + (else + (error "invalid character in escape sequence: ~S" ch))))) + + (define (read-fixed-hex-escape len) + (let lp ((len len) (res 0)) + (if (zero? len) + (integer->char res) + (let ((ch (next))) + (cond + ((hex-digit ch) => + (lambda (digit) + (lp (1- len) (+ (* res 16) digit)))) + ((eof-object? ch) + (error "unexpected end of input in character escape sequence")) + (else + (error "invalid character in escape sequence: ~S" ch))))))) + + (define (read-string rdelim) + (let lp ((out '())) + (let ((ch (next))) + (cond + ((eof-object? ch) + (error "unexpected end of input while reading string")) + ((eqv? ch rdelim) + (reverse-list->string out)) + ((eqv? ch #\\) + (let ((ch (next))) + (when (eof-object? ch) + (error "unexpected end of input while reading string")) + (cond + ((eqv? ch #\newline) + (when (hungry-eol-escapes?) + ;; Skip intraline whitespace before continuing. + (let skip () + (let ((ch (peek))) + (when (and (not (eof-object? ch)) + (or (eqv? ch #\tab) + (eq? (char-general-category ch) 'Zs))) + (next) + (skip))))) + (lp out)) + ((eqv? ch rdelim) + (lp (cons rdelim out))) + (else + (lp + (cons + (case ch + ;; Accept "\(" for use at the beginning of + ;; lines in multiline strings to avoid + ;; confusing emacs lisp modes. + ((#\| #\\ #\() ch) + ((#\0) #\nul) + ((#\f) #\ff) + ((#\n) #\newline) + ((#\r) #\return) + ((#\t) #\tab) + ((#\a) #\alarm) + ((#\v) #\vtab) + ((#\b) #\backspace) + ((#\x) + (if (or (r6rs-escapes?) (eqv? rdelim #\|)) + (read-r6rs-hex-escape) + (read-fixed-hex-escape 2))) + ((#\u) + (read-fixed-hex-escape 4)) + ((#\U) + (read-fixed-hex-escape 6)) + (else + (error "invalid character in escape sequence: ~S" ch))) + out)))))) + (else + (lp (cons ch out))))))) + + (define (read-character) + (let ((ch (next))) + (cond + ((eof-object? ch) + (error "unexpected end of input after #\\")) + ((delimiter? ch) + ch) + (else + (let* ((tok (read-token ch)) + (len (string-length tok))) + (define dotted-circle #\x25cc) + (define r5rs-charnames + '(("space" . #\x20) ("newline" . #\x0a))) + (define r6rs-charnames + '(("nul" . #\x00) ("alarm" . #\x07) ("backspace" . #\x08) + ("tab" . #\x09) ("linefeed" . #\x0a) ("vtab" . #\x0b) + ("page" . #\x0c) ("return" . #\x0d) ("esc" . #\x1b) + ("delete" . #\x7f))) + (define r7rs-charnames + '(("escape" . #\x1b))) + (define C0-control-charnames + '(("nul" . #\x00) ("soh" . #\x01) ("stx" . #\x02) + ("etx" . #\x03) ("eot" . #\x04) ("enq" . #\x05) + ("ack" . #\x06) ("bel" . #\x07) ("bs" . #\x08) + ("ht" . #\x09) ("lf" . #\x0a) ("vt" . #\x0b) + ("ff" . #\x0c) ("cr" . #\x0d) ("so" . #\x0e) + ("si" . #\x0f) ("dle" . #\x10) ("dc1" . #\x11) + ("dc2" . #\x12) ("dc3" . #\x13) ("dc4" . #\x14) + ("nak" . #\x15) ("syn" . #\x16) ("etb" . #\x17) + ("can" . #\x18) ("em" . #\x19) ("sub" . #\x1a) + ("esc" . #\x1b) ("fs" . #\x1c) ("gs" . #\x1d) + ("rs" . #\x1e) ("us" . #\x1f) ("sp" . #\x20) + ("del" . #\x7f))) + (define alt-charnames + '(("null" . #\x0) ("nl" . #\x0a) ("np" . #\x0c))) + ;; Although R6RS and R7RS charnames specified as being + ;; case-sensitive, Guile matches them case-insensitively, like + ;; other char names. + (define (named-char tok alist) + (let lp ((alist alist)) + (and (pair? alist) + (if (string-ci=? tok (caar alist)) + (cdar alist) + (lp (cdr alist)))))) + (cond + ((= len 1) ch) + ((and (= len 2) (eqv? (string-ref tok 1) dotted-circle)) + ;; Ignore dotted circles, which may be used to keep + ;; combining characters from combining with the backslash in + ;; #\charname. + ch) + ((and (<= (char->integer #\0) (char->integer ch) (char->integer #\7)) + (string->number tok 8)) + ;; Specifying a codepoint as an octal value. + => integer->char) + ((and (eqv? ch #\x) (> len 1) + (string->number (substring tok 1) 16)) + ;; Specifying a codepoint as an hexadecimal value. Skip + ;; initial "x". + => integer->char) + ((named-char tok r5rs-charnames)) + ((named-char tok r6rs-charnames)) + ((named-char tok r7rs-charnames)) + ((named-char tok C0-control-charnames)) + ((named-char tok alt-charnames)) + (else + (error "unknown character name ~a" tok)))))))) + + (define (read-vector) + (list->vector (map strip-annotation (read-parenthesized #\))))) + + (define (read-srfi-4-vector ch) + (read-array ch)) + + (define (maybe-read-boolean-tail tail) + (let ((len (string-length tail))) + (let lp ((i 0)) + (or (= i len) + (let ((ch (peek))) + (and (not (eof-object? ch)) + (eqv? (char-downcase ch) (string-ref tail i)) + (or (begin + (next) + (lp (1+ i))) + (begin + (unread-char ch port) + #f)))))))) + + (define (read-false-or-srfi-4-vector) + (let ((ch (peek))) + (if (or (eqv? ch #\3) + (eqv? ch #\6)) + (read-srfi-4-vector #\f) + (begin + (maybe-read-boolean-tail "alse") + #f)))) + + (define (read-bytevector) + (define (expect ch) + (unless (eqv? (next) ch) + (error "invalid bytevector prefix" ch))) + (expect #\u) + (expect #\8) + (expect #\() + (list->typed-array 'vu8 1 + (map strip-annotation (read-parenthesized #\))))) + + ;; FIXME: We should require a terminating delimiter. + (define (read-bitvector) + (list->bitvector + (let lp () + (let ((ch (peek))) + (case ch + ((#\0) (next) (cons #f (lp))) + ((#\1) (next) (cons #t (lp))) + (else '())))))) + + (define (read-boolean ch) + ;; Historically, Guile hasn't required a delimiter after #f / #t. + ;; When the longer #false / #true forms were added, we kept this + ;; behavior. It is terrible and we should change it!! + (case ch + ((#\t #\T) + (maybe-read-boolean-tail "rue") + #t) + (else + (maybe-read-boolean-tail "alse") + #f))) + + (define (read-keyword) + (let ((expr (strip-annotation (read-subexpression "keyword")))) + (unless (symbol? expr) + (error "keyword prefix #: not followed by a symbol: ~a" expr)) + (symbol->keyword expr))) + + (define (read-array ch) + (define (read-decimal-integer ch alt) + ;; This parser has problems but it's what Guile's read.c does. Any + ;; fix should come later and to both of them. + (define (decimal-digit ch) + (and (not (eof-object? ch)) + (let ((digit (- (char->integer ch) (char->integer #\0)))) + (and (<= 0 digit 9) digit)))) + (let*-values (((sign ch) (if (eqv? ch #\-) + (values -1 (next)) + (values 1 ch)))) + (let lp ((ch ch) (res #f)) + (cond + ((decimal-digit ch) + => (lambda (digit) + (lp (next) (if res (+ (* 10 res) digit) digit)))) + (else + (values ch (if res (* res sign) alt))))))) + (define (read-rank ch) + (let*-values (((ch rank) (read-decimal-integer ch 1))) + (when (< rank 0) + (error "array rank must be non-negative")) + (when (eof-object? ch) + (error "unexpected end of input while reading array")) + (values ch rank))) + (define (read-tag ch) + (let lp ((ch ch) (chars '())) + (when (eof-object? ch) + (error "unexpected end of input while reading array")) + (if (memv ch '(#\( #\@ #\:)) + (values ch + (if (null? chars) + #t + (string->symbol (list->string (reverse chars))))) + (lp (next) (cons ch chars))))) + (define (read-dimension ch) + (let*-values (((ch lbnd) (if (eqv? ch #\@) + (read-decimal-integer (next) 0) + (values ch 0))) + ((ch len) (if (eqv? ch #\:) + (read-decimal-integer (next) 0) + (values ch #f)))) + (when (and len (< len 0)) + (error "array length must be non-negative")) + (when (eof-object? ch) + (error "unexpected end of input while reading array")) + (values ch + (if len + (list lbnd (+ lbnd (1- len))) + lbnd)))) + (define (read-shape ch alt) + (if (memv ch '(#\@ #\:)) + (let*-values (((ch head) (read-dimension ch)) + ((ch tail) (read-shape ch '()))) + (values ch (cons head tail))) + (values ch alt))) + (define (read-elements ch rank) + (unless (eqv? ch #\() + (error "missing '(' in vector or array literal")) + (let ((elts (map strip-annotation (read-parenthesized #\))))) + (if (zero? rank) + (begin + ;; Handle special print syntax of rank zero arrays; see + ;; scm_i_print_array for a rationale. + (when (null? elts) + (error "too few elements in array literal, need 1")) + (unless (null? (cdr elts)) + (error "too many elements in array literal, need 1")) + (car elts)) + elts))) + (let*-values (((ch rank) (read-rank ch)) + ((ch tag) (read-tag ch)) + ((ch shape) (read-shape ch rank)) + ((elts) (read-elements ch rank))) + (when (and (pair? shape) (not (eqv? (length shape) rank))) + (error "the number of shape specifications must match the array rank")) + (list->typed-array tag shape elts))) + + (define (read-number-and-radix ch) + (let ((tok (string-append "#" (read-token ch)))) + (or (string->number tok) + (error "unknown # object: ~S" tok)))) + + (define (read-extended-symbol) + (define (next-not-eof) + (let ((ch (next))) + (when (eof-object? ch) + (error "end of input while reading symbol")) + ch)) + (string->symbol + (list->string + (let lp ((saw-brace? #f)) + (let ((ch (next-not-eof))) + (cond + (saw-brace? + (if (eqv? ch #\#) + '() + (cons #\} (lp #f)))) + ((eqv? ch #\}) + (lp #t)) + ((eqv? ch #\\) + ;; It used to be that print.c would print extended-read-syntax + ;; symbols with backslashes before "non-standard" chars, but + ;; this routine wouldn't do anything with those escapes. + ;; Bummer. What we've done is to change print.c to output + ;; R6RS hex escapes for those characters, relying on the fact + ;; that the extended read syntax would never put a `\' before + ;; an `x'. For now, we just ignore other instances of + ;; backslash in the string. + (let* ((ch (next-not-eof)) + (ch (if (eqv? ch #\x) + (read-r6rs-hex-escape) + ch))) + (cons ch (lp #f)))) + (else + (cons ch (lp #f))))))))) + + (define (read-nil) + ;; Have already read "#\n" -- now read "il". + (let ((id (read-mixed-case-symbol #\n))) + (unless (eq? id 'nil) + (error "unexpected input while reading #nil: ~a" id)) + #nil)) + + (define (read-sharp) + (let* ((ch (next))) + (cond + ((eof-object? ch) + (error "unexpected end of input after #")) + ((read-hash-procedure ch) + => (lambda (proc) (proc ch port))) + (else + (case ch + ((#\\) (read-character)) + ((#\() (read-vector)) + ((#\s #\u #\c) (read-srfi-4-vector ch)) + ((#\f) (read-false-or-srfi-4-vector)) + ((#\v) (read-bytevector)) + ((#\*) (read-bitvector)) + ((#\t #\T #\F) (read-boolean ch)) + ((#\:) (read-keyword)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\@) + (read-array ch)) + ((#\i #\e #\b #\B #\o #\O #\d #\D #\x #\X #\I #\E) + (read-number-and-radix ch)) + ((#\{) (read-extended-symbol)) + ((#\') (list 'syntax (read-subexpression "syntax expression"))) + ((#\`) (list 'quasisyntax + (read-subexpression "quasisyntax expression"))) + ((#\,) + (if (eqv? #\@ (peek)) + (begin + (next) + (list 'unsyntax-splicing + (read-subexpression "unsyntax-splicing expression"))) + (list 'unsyntax (read-subexpression "unsyntax expression")))) + ((#\n) (read-nil)) + (else + (error "Unknown # object: ~S" (string #\# ch)))))))) + + (define (read-number ch) + (let* ((str (read-token ch))) + (or (string->number str) + (string->symbol (if (case-insensitive?) + (string-downcase str) + str))))) + + (define (read-expr* ch) + (case ch + ((#\{) + (cond + ((curly-infix?) + (set! neoteric (1+ neoteric)) + (let ((expr (read-parenthesized #\}))) + (set! neoteric (1- neoteric)) + expr)) + (else + (read-mixed-case-symbol ch)))) + ((#\[) + (cond + ((square-brackets?) + (read-parenthesized #\])) + ((curly-infix?) + ;; The syntax of neoteric expressions requires that '[' be a + ;; delimiter when curly-infix is enabled, so it cannot be part + ;; of an unescaped symbol. We might as well do something + ;; useful with it, so we adopt Kawa's convention: [...] => + ;; ($bracket-list$ ...) + ;; FIXME: source locations for this cons + (cons '$bracket-list$ (read-parenthesized #\]))) + (else + (read-mixed-case-symbol ch)))) + ((#\() + (read-parenthesized #\))) + ((#\") + (read-string ch)) + ((#\|) + (if (r7rs-symbols?) + (string->symbol (read-string ch)) + (read-mixed-case-symbol ch))) + ((#\') + (list 'quote (read-subexpression "quoted expression"))) + ((#\`) + (list 'quasiquote (read-subexpression "quasiquoted expression"))) + ((#\,) + (cond + ((eqv? #\@ (peek)) + (next) + (list 'unquote-splicing (read-subexpression "subexpression of ,@"))) + (else + (list 'unquote (read-subexpression "unquoted expression"))))) + ((#\#) + ;; FIXME: read-sharp should recur if we read a comment + (read-sharp)) + ((#\)) + (error "unexpected \")\"")) + ((#\}) + (if (curly-infix?) + (error "unexpected \"}\"") + (read-mixed-case-symbol ch))) + ((#\]) + (if (square-brackets?) + (error "unexpected \"]\"") + (read-mixed-case-symbol ch))) + ((#\:) + (if (eq? (keyword-style) keyword-style-prefix) + ;; FIXME: Don't skip whitespace here. + (let ((sym (read-subexpression ":keyword"))) + (symbol->keyword (strip-annotation sym))) + (read-mixed-case-symbol ch))) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\- #\.) + (read-number ch)) + (else + (read-mixed-case-symbol ch)))) + + (define (read-neoteric ch) + (let lp ((expr (read-expr* ch))) + ;; 'expr' is the first component of the neoteric expression. If + ;; the next character is '(', '[', or '{', (without any + ;; intervening whitespace), we use it to construct a new + ;; expression, and loop. For example: + ;; f{n - 1}(x) => ((f (- n 1)) x). + (case (peek) + ((#\() ;; e(...) => (e ...) + (next) + (lp (cons expr (read-parenthesized #\))))) + ((#\[) ;; e[...] => ($bracket-apply$ e ...) + (next) + (lp (cons* '$bracket-apply$ expr (read-parenthesized #\])))) + ((#\{) ;; e{} => (e); e{...} => (e {...}) + (next) + (let ((args (read-parenthesized #\}))) + (lp (if (null? args) + (list expr) + (list expr args))))) + (else + expr)))) + + (define (read-expr ch) + (let ((line (port-line port)) + (column (port-column port))) + (annotate line + column + (if (zero? neoteric) + (read-expr* ch) + (read-neoteric ch))))) + + (define (read-directive) + (let ((ch (next))) + (cond + ((eof-object? ch) + (error "unexpected end of input after #!")) + (else + (string->symbol + (take-while ch (lambda (ch) + (or (eqv? ch #\-) + (char-alphabetic? ch) + (char-numeric? ch))))))))) + + (define (skip-scsh-comment) + (let lp ((ch (next))) + (cond + ((eof-object? ch) + (error "unterminated `#! ... !#' comment")) + ((eqv? ch #\!) + (let ((ch (next))) + (if (eqv? ch #\#) + (next) + (lp ch)))) + (else + (lp (next)))))) + + (define (process-shebang) + ;; After having read #!, we complete either with #!r6rs, + ;; #!fold-case, #!no-fold-case, #!curly-infix, + ;; #!curly-infix-and-bracket-lists, or a SCSH block comment + ;; terminated by !#. + (let ((sym (read-directive))) + (cond + ((eq? sym 'r6rs) + (set-reader-option! bitfield:case-insensitive? 0) + (set-reader-option! bitfield:r6rs-escapes? 1) + (set-reader-option! bitfield:square-brackets? 1) + (set-reader-option! bitfield:keyword-style keyword-style-hash-prefix) + (set-reader-option! bitfield:hungry-eol-escapes? 1) + (next)) + ((eq? sym 'fold-case) + (set-reader-option! bitfield:case-insensitive? 1) + (next)) + ((eq? sym 'no-fold-case) + (set-reader-option! bitfield:case-insensitive? 0) + (next)) + ((eq? sym 'curly-infix) + (set-reader-option! bitfield:curly-infix? 1) + (next)) + ((eq? sym 'curly-infix-and-bracket-lists) + (set-reader-option! bitfield:curly-infix? 1) + (set-reader-option! bitfield:square-brackets? 0) + (next)) + (else + (skip-scsh-comment))))) + + (define (skip-eol-comment) + (let ((ch (next))) + (cond + ((eof-object? ch) ch) + ((eq? ch #\newline) (next)) + (else (skip-eol-comment))))) + + ;; Unlike SCSH-style block comments, SRFI-30/R6RS block comments may be + ;; nested. + (define (skip-r6rs-block-comment) + ;; We have read #|, now looking for |#. + (let ((ch (next))) + (when (eof-object? ch) + (error "unterminated `#| ... |#' comment")) + (cond + ((and (eqv? ch #\|) (eqv? (peek) #\#)) + ;; Done. + (next) + (values)) + ((and (eqv? ch #\#) (eqv? (peek) #\|)) + ;; A nested comment. + (next) + (skip-r6rs-block-comment) + (skip-r6rs-block-comment)) + (else + (skip-r6rs-block-comment))))) + + (define (read-subexpression what) + (let ((ch (next-non-whitespace))) + (when (eof-object? ch) + (error (string-append "unexpected end of input while reading " what))) + (read-expr ch))) + + (define (next-non-whitespace) + (let lp ((ch (next))) + (case ch + ((#\;) + (lp (skip-eol-comment))) + ((#\#) + (case (peek) + ((#\!) + (next) + (lp (process-shebang))) + ((#\;) + (next) + (read-subexpression "#; comment") + (next-non-whitespace)) + ((#\|) + (if (read-hash-procedure #\|) + ch + (begin + (next) + (skip-r6rs-block-comment) + (next-non-whitespace)))) + (else ch))) + ((#\space #\return #\ff #\newline #\tab) + (next-non-whitespace)) + (else ch)))) + + (let ((ch (next-non-whitespace))) + (if (eof-object? ch) + ch + (read-expr ch)))) + +(define* (read #:optional (port (current-input-port))) + (define filename (port-filename port)) + (define annotate + (if (memq 'positions (read-options)) + (lambda (line column datum) + (when (and (supports-source-properties? datum) + ;; Line or column can be invalid via + ;; set-port-column! or ungetting chars beyond start + ;; of line. + (<= 0 line) + (<= 1 column)) + ;; We always capture the column after one char of lookahead; + ;; subtract off that lookahead value. + (set-source-properties! datum + `((filename . ,filename) + (line . ,line) + (column . ,(1- column))))) + datum) + (lambda (line column datum) + datum))) + (%read port annotate identity)) + +(define* (read-syntax #:optional (port (current-input-port))) + (define filename (port-filename port)) + (define (annotate line column datum) + (datum->syntax #f ; No lexical context. + datum + #:source (vector filename line (1- column)))) + (%read port annotate syntax->datum)) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index db52956e7..574c39bd2 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1,5 +1,5 @@ ;;; Type analysis on CPS -;;; Copyright (C) 2014-2020 Free Software Foundation, Inc. +;;; Copyright (C) 2014-2021 Free Software Foundation, Inc. ;;; ;;; This library is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU Lesser General Public License as @@ -368,6 +368,7 @@ minimum, and maximum." ((eq? val #t) (return &special-immediate &true)) ((eq? val #f) (return &special-immediate &false)) ((eqv? val *unspecified*) (return &special-immediate &unspecified)) + ((eof-object? val) (return &special-immediate &eof)) ((char? val) (return &char (char->integer val))) ((symbol? val) (return &symbol #f)) ((keyword? val) (return &keyword #f)) diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm index e4cf55c4c..18af552ef 100644 --- a/module/language/scheme/spec.scm +++ b/module/language/scheme/spec.scm @@ -1,6 +1,6 @@ ;;; Guile Scheme specification -;; Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2021 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -37,7 +37,7 @@ ((or (and=> (and=> (module-variable env 'current-reader) variable-ref) fluid-ref) - read) + read-syntax) port)) #:compilers `((tree-il . ,compile-tree-il)) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index b257aa17c..1cc7907a8 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -1,6 +1,6 @@ ;;; open-coding primitive procedures -;; Copyright (C) 2009-2015, 2017-2020 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015, 2017-2021 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -52,6 +52,7 @@ sqrt abs floor ceiling sin cos tan asin acos atan not pair? null? list? symbol? vector? string? struct? number? char? nil? + eof-object? bytevector? keyword? bitvector? symbol->string string->symbol @@ -199,7 +200,7 @@ eq? eqv? equal? not pair? null? nil? list? - symbol? variable? vector? struct? string? number? char? + symbol? variable? vector? struct? string? number? char? eof-object? exact-integer? bytevector? keyword? bitvector? procedure? thunk? atomic-box? @@ -404,6 +405,12 @@ (define-primitive-expander module-define! (mod sym val) (%variable-set! (module-ensure-local-variable! mod sym) val)) +(define-primitive-expander! 'eof-object? + (match-lambda* + ((src obj) + (make-primcall src 'eq? (list obj (make-const #f the-eof-object)))) + (_ #f))) + (define-primitive-expander zero? (x) (= x 0)) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index df6df4f7b..9edc16b07 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1,6 +1,6 @@ ;;;; goops.scm -- The Guile Object-Oriented Programming System ;;;; -;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018 +;;;; Copyright (C) 1998-2003,2006,2009-2011,2013-2015,2017-2018,2021 ;;;; Free Software Foundation, Inc. ;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> ;;;; @@ -3307,10 +3307,15 @@ var{initargs}." (define <directory> (find-subclass <top> '<directory>)) (define <array> (find-subclass <top> '<array>)) (define <character-set> (find-subclass <top> '<character-set>)) -(define <dynamic-object> (find-subclass <top> '<dynamic-object>)) (define <guardian> (find-subclass <applicable> '<guardian>)) (define <macro> (find-subclass <top> '<macro>)) +;; <dynamic-object> used to be a SMOB type, albeit not exported even to +;; C. However now it's a record type, though still private. Cross our +;; fingers that nobody is using it in anger! +(define <dynamic-object> + (module-ref (resolve-module '(system foreign-library)) '<foreign-library>)) + (define (define-class-subtree class) (define! (class-name class) class) (for-each define-class-subtree (class-direct-subclasses class))) diff --git a/module/system/foreign-library.scm b/module/system/foreign-library.scm new file mode 100644 index 000000000..eaeb26700 --- /dev/null +++ b/module/system/foreign-library.scm @@ -0,0 +1,231 @@ +;;; Dynamically linking foreign libraries via dlopen and dlsym +;;; Copyright (C) 2021 Free Software Foundation, Inc. +;;; +;;; This library is free software: you can redistribute it and/or modify +;;; it under the terms of the GNU Lesser General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; Implementation of dynamic-link. +;;; +;;; Code: + + +(define-module (system foreign-library) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (system foreign) + #:export (guile-extensions-path + ltdl-library-path + guile-system-extensions-path + + load-foreign-library + foreign-library? + foreign-library-pointer + foreign-library-function)) + +(define-record-type <foreign-library> + (make-foreign-library filename handle) + foreign-library? + (filename foreign-library-filename) + (handle foreign-library-handle set-foreign-library-handle!)) + +(eval-when (expand load eval) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_system_foreign_library")) + +(define system-library-extensions + (cond + ((string-contains %host-type "-darwin-") + '(".bundle" ".so" ".dylib")) + ((or (string-contains %host-type "cygwin") + (string-contains %host-type "mingw") + (string-contains %host-type "msys")) + '(".dll")) + (else + '(".so")))) + +(define (has-extension? head exts) + (match exts + (() #f) + ((ext . exts) + (or (string-contains head ext) + (has-extension? head exts))))) + +(define (file-exists-with-extension head exts) + (if (has-extension? head exts) + (and (file-exists? head) head) + (let lp ((exts exts)) + (match exts + (() #f) + ((ext . exts) + (let ((head (string-append head ext))) + (if (file-exists? head) + head + (lp exts)))))))) + +(define (file-exists-in-path-with-extension basename path exts) + (match path + (() #f) + ((dir . path) + (or (file-exists-with-extension (in-vicinity dir basename) exts) + (file-exists-in-path-with-extension basename path exts))))) + +(define path-separator + (case (system-file-name-convention) + ((posix) #\:) + ((windows) #\;) + (else (error "unreachable")))) + +(define (parse-path var) + (match (getenv var) + (#f #f) + ;; Ignore e.g. "export GUILE_SYSTEM_EXTENSIONS_PATH=". + ("" '()) + (val (string-split val path-separator)))) + +(define guile-extensions-path + (make-parameter + (or (parse-path "GUILE_EXTENSIONS_PATH") '()))) + +(define ltdl-library-path + (make-parameter + (or (parse-path "LTDL_LIBRARY_PATH") '()))) + +(define guile-system-extensions-path + (make-parameter + (or (parse-path "GUILE_SYSTEM_EXTENSIONS_PATH") + (list (assq-ref %guile-build-info 'libdir) + (assq-ref %guile-build-info 'extensiondir))))) + +;; There are a few messy situations here related to libtool. +;; +;; Guile used to use libltdl, the dynamic library loader provided by +;; libtool. This loader used LTDL_LIBRARY_PATH, and for backwards +;; compatibility we still support that path. +;; +;; However, libltdl would not only open ".so" (or ".dll", etc) files, +;; but also the ".la" files created by libtool. In installed libraries +;; -- libraries that are in the target directories of "make install" -- +;; .la files are never needed, to the extent that most GNU/Linux +;; distributions remove them entirely. It is sufficient to just load +;; the ".so" (or ".dll", etc) files. +;; +;; But for uninstalled dynamic libraries, like those in a build tree, it +;; is a bit of a mess. If you have a project that uses libtool to build +;; libraries -- which is the case for Guile, and for most projects using +;; autotools -- and you build foo.so in directory D, libtool will put +;; foo.la in D, but foo.so goes in D/.libs. +;; +;; The nice thing about ltdl was that it could load the .la file, even +;; from a build tree, preventing the existence of ".libs" from leaking +;; out to the user. +;; +;; We don't use libltdl now, essentially for flexibility and +;; error-reporting reasons. But, it would be nice to keep this old +;; use-case working. So as a stopgap solution, we add a ".libs" subdir +;; to the path for each entry in LTDL_LIBRARY_PATH, in case the .so is +;; there instead of alongside the .la file. +(define (augment-ltdl-library-path path) + (match path + (() '()) + ((dir . path) + (cons* dir (in-vicinity dir ".libs") + (augment-ltdl-library-path path))))) + +(define (default-search-path search-ltdl-library-path?) + (append + (guile-extensions-path) + (if search-ltdl-library-path? + (augment-ltdl-library-path (ltdl-library-path)) + '()) + (guile-system-extensions-path))) + +(define* (load-foreign-library #:optional filename #:key + (extensions system-library-extensions) + (search-ltdl-library-path? #t) + (search-path (default-search-path + search-ltdl-library-path?)) + (search-system-paths? #t) + (lazy? #t) (global? #f)) + (define (error-not-found) + (scm-error 'misc-error "load-foreign-library" + "file: ~S, message: ~S" + (list filename "file not found") + #f)) + (define flags + (logior (if lazy? RTLD_LAZY RTLD_NOW) + (if global? RTLD_GLOBAL RTLD_LOCAL))) + (define (dlopen* name) (dlopen name flags)) + (make-foreign-library + filename + (cond + ((not filename) + ;; The self-open trick. + (dlopen* #f)) + ((or (absolute-file-name? filename) + (string-any file-name-separator? filename)) + (cond + ((or (file-exists-with-extension filename extensions) + (and search-ltdl-library-path? + (file-exists-with-extension + (in-vicinity (in-vicinity (dirname filename) ".libs") + (basename filename)) + extensions))) + => dlopen*) + (else + (error-not-found)))) + ((file-exists-in-path-with-extension filename search-path extensions) + => dlopen*) + (search-system-paths? + (if (or (null? extensions) (has-extension? filename extensions)) + (dlopen* filename) + (let lp ((extensions extensions)) + (match extensions + ((extension) + ;; Open in tail position to propagate any exception. + (dlopen* (string-append filename extension))) + ((extension . extensions) + ;; If there is more than one extension, unfortunately we + ;; only report the error for the last extension. This is + ;; not great because maybe the library was found with the + ;; first extension, failed to load and had an interesting + ;; error, but then we swallowed that interesting error and + ;; proceeded, eventually throwing a "file not found" + ;; exception. FIXME to use more structured exceptions and + ;; stop if the error that we get is more specific than + ;; just "file not found". + (or (false-if-exception + (dlopen* (string-append filename extension))) + (lp extensions))))))) + (else + (error-not-found))))) + +(define (->foreign-library lib) + (if (foreign-library? lib) + lib + (load-foreign-library lib))) + +(define* (foreign-library-pointer lib name) + (let ((handle (foreign-library-handle (->foreign-library lib)))) + (dlsym handle name))) + +(define* (foreign-library-function lib name + #:key + (return-type void) + (arg-types '()) + (return-errno? #f)) + (let ((pointer (foreign-library-pointer lib name))) + (pointer->procedure return-type pointer arg-types + #:return-errno? return-errno?))) diff --git a/module/system/syntax.scm b/module/system/syntax.scm index 34fadb39f..ee8521234 100644 --- a/module/system/syntax.scm +++ b/module/system/syntax.scm @@ -1,6 +1,6 @@ ;;; Syntax utilities -;;; Copyright (C) 2017 Free Software Foundation, Inc. +;;; Copyright (C) 2017, 2021 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -30,4 +30,13 @@ (define (print-syntax obj port) ;; FIXME: Use syntax->datum instad of syntax-expression, when ;; syntax->datum can operate on new syntax objects. - (format port "#<syntax ~s>" (syntax-expression obj))) + (let ((src (syntax-sourcev obj))) + (if src + (format port "#<syntax:~a:~a:~a ~s>" + (cond + ((vector-ref src 0) => basename) + (else "unknown file")) + (1+ (vector-ref src 1)) + (vector-ref src 2) + (syntax-expression obj)) + (format port "#<syntax ~s>" (syntax-expression obj))))) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 8599aa005..8139263a8 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1,6 +1,6 @@ ;;; Guile bytecode assembler -;;; Copyright (C) 2001, 2009-2020 Free Software Foundation, Inc. +;;; Copyright (C) 2001, 2009-2021 Free Software Foundation, Inc. ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Lesser General Public @@ -545,8 +545,17 @@ N-byte unit." ;; (constants asm-constants set-asm-constants!) - ;; A list of instructions needed to initialize the constants. Will - ;; run in a thunk with 2 local variables. + ;; A vhash of label to init descriptors, where an init descriptor is + ;; #(EMIT-INIT STATIC? PATCHES). EMIT-INIT, if present, is a + ;; procedure taking the asm and the label as arguments. Unless the + ;; object is statically allocatable, in which case it can be loaded + ;; via make-non-immediate rather than static-ref, EMIT-INIT should + ;; also initialize the corresponding cell for any later static-ref. + ;; If STATIC? is true, the value can be loaded with + ;; emit-make-non-immediate, otherwise it's emit-static-ref. A bit + ;; confusing but that's how it is. PATCHES is a list of (DEST-LABEL + ;; . FIELD) pairs, indicating locations to which to patch the value. + ;; Like asm-constants, order is important. ;; (inits asm-inits set-asm-inits!) @@ -582,7 +591,7 @@ target." (make-asm (make-u32vector 1000) 0 0 (make-hash-table) '() word-size endianness - vlist-null '() + vlist-null vlist-null (make-string-table) 1 '() '() '())) @@ -1249,51 +1258,77 @@ used to reference it. If the object is already present in the constant table, its existing label is used directly." (define (recur obj) (intern-constant asm obj)) - (define (field dst n obj) - (let ((src (recur obj))) - (if src - (if (statically-allocatable? obj) - `((static-patch! ,dst ,n ,src)) - `((static-ref 1 ,src) - (static-set! 1 ,dst ,n))) - '()))) - (define (intern obj label) + (define (add-desc! label desc) + (set-asm-inits! asm (vhash-consq label desc (asm-inits asm)))) + (define (init-descriptor obj) + (let ((label (recur obj))) + (cond + ((not label) #f) + ((vhash-assq label (asm-inits asm)) => cdr) + (else + (let ((desc (vector #f #t '()))) + (add-desc! label desc) + desc))))) + (define (add-patch! dst field obj) + (match (init-descriptor obj) + (#f #f) + ((and desc #(emit-init emit-load patches)) + (vector-set! desc 2 (acons dst field patches))))) + (define (add-init! dst init) + (add-desc! dst (vector init #f '()))) + (define (intern! obj label) + (define (patch! field obj) (add-patch! label field obj)) + (define (init! emit-init) (add-init! label emit-init)) (cond ((pair? obj) - (append (field label 0 (car obj)) - (field label 1 (cdr obj)))) + (patch! 0 (car obj)) + (patch! 1 (cdr obj))) ((simple-vector? obj) - (let lp ((i 0) (inits '())) - (if (< i (vector-length obj)) - (lp (1+ i) - (append-reverse (field label (1+ i) (vector-ref obj i)) - inits)) - (reverse inits)))) + (let lp ((i 0)) + (when (< i (vector-length obj)) + (patch! (1+ i) (vector-ref obj i)) + (lp (1+ i))))) ((syntax? obj) - (append (field label 1 (syntax-expression obj)) - (field label 2 (syntax-wrap obj)) - (field label 3 (syntax-module obj)))) - ((stringbuf? obj) '()) + (patch! 1 (syntax-expression obj)) + (patch! 2 (syntax-wrap obj)) + (patch! 3 (syntax-module obj)) + (patch! 4 (syntax-sourcev obj))) + ((stringbuf? obj)) ((static-procedure? obj) - `((static-patch! ,label 1 ,(static-procedure-code obj)))) - ((cache-cell? obj) '()) + ;; Special case, as we can't load the procedure's code using + ;; make-non-immediate. + (let* ((code (static-procedure-code obj)) + (init (lambda (asm label) + (emit-static-patch! asm label 1 code) + #f))) + (add-desc! label (vector init #t '())))) + ((cache-cell? obj)) ((symbol? obj) (unless (symbol-interned? obj) (error "uninterned symbol cannot be saved to object file" obj)) - `((make-non-immediate 1 ,(recur (symbol->string obj))) - (string->symbol 1 1) - (static-set! 1 ,label 0))) + (let ((str-label (recur (symbol->string obj)))) + (init! (lambda (asm label) + (emit-make-non-immediate asm 1 str-label) + (emit-string->symbol asm 1 1) + (emit-static-set! asm 1 label 0) + 1)))) ((string? obj) - `((static-patch! ,label 1 ,(recur (make-stringbuf obj))))) + (patch! 1 (make-stringbuf obj))) ((keyword? obj) - `((static-ref 1 ,(recur (keyword->symbol obj))) - (symbol->keyword 1 1) - (static-set! 1 ,label 0))) + (let ((sym-label (recur (keyword->symbol obj)))) + (init! (lambda (asm label) + (emit-static-ref asm 1 sym-label) + (emit-symbol->keyword asm 1 1) + (emit-static-set! asm 1 label 0) + 1)))) ((number? obj) - `((make-non-immediate 1 ,(recur (number->string obj))) - (string->number 1 1) - (static-set! 1 ,label 0))) - ((uniform-vector-backing-store? obj) '()) + (let ((str-label (recur (number->string obj)))) + (init! (lambda (asm label) + (emit-make-non-immediate asm 1 str-label) + (emit-string->number asm 1 1) + (emit-static-set! asm 1 label 0) + 1)))) + ((uniform-vector-backing-store? obj)) ((simple-uniform-vector? obj) (let ((width (case (array-type obj) ((vu8 u8 s8) 1) @@ -1305,23 +1340,22 @@ table, its existing label is used directly." ((u64 s64 f64 c64) 8) (else (error "unhandled array type" obj))))) - `((static-patch! ,label 2 - ,(recur (make-uniform-vector-backing-store - (uniform-array->bytevector obj) - width)))))) + (patch! 2 + (make-uniform-vector-backing-store + (uniform-array->bytevector obj) + width)))) ((array? obj) - `((static-patch! ,label 1 ,(recur (shared-array-root obj))))) + (patch! 1 (shared-array-root obj))) (else (error "don't know how to intern" obj)))) (cond ((immediate-bits asm obj) #f) ((vhash-assoc obj (asm-constants asm)) => cdr) (else - ;; Note that calling intern may mutate asm-constants and asm-inits. - (let* ((label (gensym "constant")) - (inits (intern obj label))) + (let ((label (gensym "constant"))) + ;; Note that calling intern may mutate asm-constants and asm-inits. + (intern! obj label) (set-asm-constants! asm (vhash-cons obj label (asm-constants asm))) - (set-asm-inits! asm (append-reverse inits (asm-inits asm))) label)))) (define (intern-non-immediate asm obj) @@ -1741,17 +1775,36 @@ corresponding linker symbol for the start of the section." "If there is writable data that needs initialization at runtime, emit a procedure to do that and return its label. Otherwise return @code{#f}." - (let ((inits (asm-inits asm))) - (and (not (null? inits)) + (let* ((inits (asm-inits asm))) + (and (not (vlist-null? inits)) (let ((label (gensym "init-constants"))) - (emit-text asm - `((begin-program ,label ()) - (assert-nargs-ee/locals 1 1) - ,@(reverse inits) - (reset-frame 1) - (load-constant 0 ,*unspecified*) - (return-values) - (end-program))) + (emit-begin-program asm label '()) + (emit-assert-nargs-ee/locals asm 1 1) + (let lp ((n (1- (vlist-length inits)))) + (match (vlist-ref inits n) + ((label . #(#f #t ((dst . field)))) + ;; Special case in which emit-static-patch is actually + ;; an optimization. + (emit-static-patch! asm dst field label)) + ((label . #(emit-init static? patches)) + (let ((slot-from-init (and emit-init (emit-init asm label)))) + (unless (null? patches) + (let ((slot (or slot-from-init + (begin + (if static? + (emit-make-non-immediate asm 1 label) + (emit-static-ref asm 1 label)) + 1)))) + (for-each (match-lambda + ((dst . offset) + (emit-static-set! asm slot dst offset))) + patches)))))) + (unless (zero? n) + (lp (1- n)))) + (emit-reset-frame asm 1) + (emit-load-constant asm 0 *unspecified*) + (emit-return-values asm) + (emit-end-program asm) label)))) (define (link-data asm data name) @@ -1772,6 +1825,7 @@ should be .data or .rodata), and return the resulting linker object. (define stringbuf-wide-flag #x400) (define tc7-syntax #x3d) + (define syntax-has-source-flag #x100) (define tc7-program #x45) @@ -1804,7 +1858,7 @@ should be .data or .rodata), and return the resulting linker object. ((simple-vector? x) (* (1+ (vector-length x)) word-size)) ((syntax? x) - (* 4 word-size)) + (* 5 word-size)) ((jit-data? x) (case word-size ((4) (+ word-size (* 4 3))) @@ -1920,16 +1974,19 @@ should be .data or .rodata), and return the resulting linker object. (write-placeholder asm buf pos)) ((syntax? obj) - (case word-size - ((4) (bytevector-u32-set! buf pos tc7-syntax endianness)) - ((8) (bytevector-u64-set! buf pos tc7-syntax endianness)) - (else (error "bad word size"))) + (let ((tag (logior tc7-syntax syntax-has-source-flag))) + (case word-size + ((4) (bytevector-u32-set! buf pos tag endianness)) + ((8) (bytevector-u64-set! buf pos tag endianness)) + (else (error "bad word size")))) (write-constant-reference buf (+ pos (* 1 word-size)) (syntax-expression obj)) (write-constant-reference buf (+ pos (* 2 word-size)) (syntax-wrap obj)) (write-constant-reference buf (+ pos (* 3 word-size)) - (syntax-module obj))) + (syntax-module obj)) + (write-constant-reference buf (+ pos (* 4 word-size)) + (syntax-sourcev obj))) ((number? obj) (write-placeholder asm buf pos)) diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index e913e30a2..c2716ed17 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -1016,6 +1016,10 @@ (pass-if-equal "empty 3-array with last nonempty dim." "#3:0:0:1()" (format #f "~a" (make-array 1 0 0 1))) + + (pass-if-equal "empty typed 3-array with last nonempty dim." + "#3f64:0:0:1()" + (format #f "~a" (make-typed-array 'f64 1 0 0 1))) (pass-if-equal "empty 3-array with middle nonempty dim." "#3:0:1:0()" @@ -1053,3 +1057,37 @@ "#3@1@-1@1(((1)) ((1)) ((1)))" (format #f "~a" (make-array 1 '(1 3) '(-1 -1) '(1 1))))) +;;; +;;; reading arrays +;;; + +(with-test-prefix/c&e "reading arrays" + + (pass-if "empty 3-array with first nonempty dim I" + (array-equal? (make-array 1 1 0 0) + (call-with-input-string "#3(())" read))) + (pass-if "empty 3-array with first nonempty dim II" + (array-equal? (make-array 1 1 0 0) + #3(()))) + + (pass-if "empty 3-array with middle nonempty dim I" + (array-equal? (make-array 1 0 1 0) + (call-with-input-string "#3:0:1:0()" read))) + (pass-if "empty 3-array with middle nonempty dim II" + (array-equal? (make-array 1 0 1 0) + #3:0:1:0())) + + (pass-if "empty typed 3-array with middle nonempty dim I" + (array-equal? (make-typed-array 'f64 1 0 1 0) + (call-with-input-string "#3f64:0:1:0()" read))) + (pass-if "empty typed 3-array with middle nonempty dim II" + (array-equal? (make-typed-array 'f64 1 0 1 0) + #3f64:0:1:0())) + + (pass-if "array with specified size I" + (array-equal? #f64(1 2 3) + (call-with-input-string "#f64:3(1 2 3)" read))) + (pass-if "array with specified size II" + (array-equal? #f64(1 2 3) + #f64:3(1 2 3)))) + diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index 5d4568d82..9ae040f1e 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -1,6 +1,6 @@ ;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2009-2015, 2018 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2015, 2018, 2021 Free Software Foundation, Inc. ;;;; ;;;; Ludovic Courtès ;;;; @@ -645,11 +645,11 @@ (with-input-from-string "#vu8 (1 2 3)" read)) (pass-if-exception "negative integers" - exception:wrong-type-arg + exception:out-of-range (with-input-from-string "#vu8(-1 -2 -3)" read)) (pass-if-exception "out-of-range integers" - exception:wrong-type-arg + exception:out-of-range (with-input-from-string "#vu8(0 256)" read))) diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test index 55cfead23..0a3b31491 100644 --- a/test-suite/tests/chars.test +++ b/test-suite/tests/chars.test @@ -1,7 +1,7 @@ ;;;; chars.test --- Characters. -*- coding: utf-8; mode: scheme; -*- ;;;; Greg J. Badros <gjb@cs.washington.edu> ;;;; -;;;; Copyright (C) 2000, 2006, 2009, 2010, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2006, 2009, 2010, 2013, 2021 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -25,9 +25,6 @@ (define exception:unknown-character-name (cons #t "unknown character")) -(define exception:out-of-range-octal - (cons #t "out-of-range")) - (with-test-prefix "basic char handling" @@ -237,11 +234,11 @@ (integer->char #x110000)) (pass-if-exception "octal out of range, surrrogate" - exception:out-of-range-octal + exception:out-of-range (with-input-from-string "#\\154000" read)) (pass-if-exception "octal out of range, too big" - exception:out-of-range-octal + exception:out-of-range (with-input-from-string "#\\4200000" read))) (with-test-prefix "case" diff --git a/test-suite/tests/dwarf.test b/test-suite/tests/dwarf.test index bf36b65d8..53e87987a 100644 --- a/test-suite/tests/dwarf.test +++ b/test-suite/tests/dwarf.test @@ -1,6 +1,6 @@ ;;;; dwarf.test -*- scheme -*- ;;;; -;;;; Copyright 2013 Free Software Foundation, Inc. +;;;; Copyright 2013, 2021 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -26,7 +26,7 @@ (define prog (string-concatenate - ;; Every open parenthesis is a possible source location. + ;; The start of every datum is a possible source location. '("(define (qux f)\n" ;^ 0:0 " (+ 32 (f)))\n" @@ -37,6 +37,7 @@ " (lambda (a)\n" ; ^ 4:2 " 13))\n" + ; ^ 5:4 "'success\n") )) @@ -81,10 +82,15 @@ (error "unexpected sources" sources))) (match (find-program-sources (program-code bar)) - ((source) - (pass-if-equal "foo.scm" (source-file source)) - (pass-if-equal 4 (source-line source)) - (pass-if-equal 5 (source-line-for-user source)) - (pass-if-equal 2 (source-column source))) + ((s1 s2) + (pass-if-equal "foo.scm" (source-file s1)) + (pass-if-equal 4 (source-line s1)) + (pass-if-equal 5 (source-line-for-user s1)) + (pass-if-equal 2 (source-column s1)) + + (pass-if-equal "foo.scm" (source-file s2)) + (pass-if-equal 5 (source-line s2)) + (pass-if-equal 6 (source-line-for-user s2)) + (pass-if-equal 4 (source-column s2))) (sources (error "unexpected sources" sources)))) diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index e61b96f6e..6fed981e5 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -1,6 +1,6 @@ ;;;; filesys.test --- test file system functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2004, 2006, 2013, 2019 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2006, 2013, 2019, 2021 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -245,7 +245,7 @@ (throw 'unresolved) (let* ((template "T-XXXXXX") (name (mkdtemp template))) - (false-if-exception (rmdir template)) + (false-if-exception (rmdir name)) (and (string? name) (string-contains name "T-") @@ -263,5 +263,5 @@ (name (mkdtemp template))) (let* ((_stat (stat name)) (result (eqv? 'directory (stat:type _stat)))) - (false-if-exception (rmdir template)) + (false-if-exception (rmdir name)) result))))) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 67b5c3790..966d214a0 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -1,6 +1,6 @@ ;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012, 2013, 2017 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012, 2013, 2017, 2021 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -21,6 +21,7 @@ ;;; (define-module (test-foreign) + #:use-module (system foreign-library) #:use-module (system foreign) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) @@ -29,12 +30,13 @@ #:use-module (test-suite lib)) -(with-test-prefix "dynamic-pointer" +(with-test-prefix "foreign-library-pointer" (pass-if-exception "error message" - '(misc-error . "^Symbol not found") - (dynamic-func "does_not_exist___" (dynamic-link)))) + ;; The error comes from dlsym, which is system-dependent. + '(misc-error . "") + (foreign-library-pointer #f "does_not_exist___"))) (with-test-prefix "null pointer" @@ -73,7 +75,7 @@ (pass-if "equal? modulo finalizer" (let ((finalizer (false-if-exception - (dynamic-func "scm_is_pair" (dynamic-link))))) + (foreign-library-pointer #f "scm_is_pair")))) (if (not finalizer) (throw 'unresolved) ; Windows or a static build (equal? (make-pointer 123) @@ -81,7 +83,7 @@ (pass-if "equal? modulo finalizer (set-pointer-finalizer!)" (let ((finalizer (false-if-exception - (dynamic-func "scm_is_pair" (dynamic-link)))) + (foreign-library-pointer #f "scm_is_pair"))) (ptr (make-pointer 123))) (if (not finalizer) (throw 'unresolved) ; Windows or a static build @@ -232,19 +234,15 @@ ;; linking with `-export-dynamic'. Just skip these tests when it's ;; not visible. (false-if-exception - (pointer->procedure void - (dynamic-func "qsort" - (cond - ((string-contains %host-type "cygwin") - ;; On Cygwin, dynamic-link does - ;; not search recursively into - ;; linked DLLs. Thus, one needs - ;; to link to the core C - ;; library DLL explicitly. - (dynamic-link "cygwin1")) - (else - (dynamic-link)))) - (list '* size_t size_t '*)))) + (foreign-library-function + (cond + ((string-contains %host-type "cygwin") + ;; On Cygwin, load-foreign-library does not search recursively + ;; into linked DLLs. Thus, one needs to link to the core C + ;; library DLL explicitly. + "cygwin1") + (else #f)) + "qsort" #:arg-types (list '* size_t size_t '*)))) (define (dereference-pointer-to-byte ptr) (let ((b (pointer->bytevector ptr 1))) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 9aa486e98..cd87640ab 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -1314,7 +1314,7 @@ (pass-if-exception "set-port-encoding!, wrong encoding" exception:miscellaneous-error - (let ((p (open-input-string ""))) + (let ((p (open-input-string "q"))) (set-port-encoding! p "does-not-exist") (read p))) diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index ef11a4abd..535ff1c8f 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -1,6 +1,6 @@ ;;;; reader.test --- Reader test. -*- coding: iso-8859-1; mode: scheme -*- ;;;; -;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015, 2020 +;;;; Copyright (C) 1999,2001-2003,2007-2011,2013-2015,2020,2021 ;;;; Free Software Foundation, Inc. ;;;; ;;;; Jim Blandy <jimb@red-bean.com> @@ -25,7 +25,7 @@ (define exception:eof - (cons 'read-error "end of file$")) + (cons 'read-error "unexpected end of input")) (define exception:unexpected-rparen (cons 'read-error "unexpected \")\"$")) (define exception:unexpected-rsqbracket @@ -37,9 +37,9 @@ (define exception:unknown-sharp-object (cons 'read-error "Unknown # object: .*$")) (define exception:eof-in-string - (cons 'read-error "end of file in string constant$")) + (cons 'read-error "end of input while reading string$")) (define exception:eof-in-symbol - (cons 'read-error "end of file while reading symbol$")) + (cons 'read-error "end of input while reading symbol$")) (define exception:invalid-escape (cons 'read-error "invalid character in escape sequence: .*$")) (define exception:missing-expression @@ -174,10 +174,10 @@ (pass-if "square brackets are parens" (equal? '() (read-string "[]"))) - (pass-if-exception "paren mismatch" exception:unexpected-rparen + (pass-if-exception "paren mismatch" exception:mismatched-paren (read-string "'[)")) - (pass-if-exception "paren mismatch (2)" exception:unexpected-rsqbracket + (pass-if-exception "paren mismatch (2)" exception:mismatched-paren (read-string "'(]")) (pass-if-exception "paren mismatch (3)" exception:mismatched-paren @@ -489,7 +489,7 @@ (eof-object? (with-input-from-string "#;foo" read))) (pass-if-exception "#;" - exception:missing-expression + exception:eof (with-input-from-string "#;" read)) (pass-if-exception "#;(" exception:eof diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test index d212bd084..34ea47b55 100644 --- a/test-suite/tests/srfi-105.test +++ b/test-suite/tests/srfi-105.test @@ -186,13 +186,19 @@ (lambda () (read-string " { 1.0 }"))))) (and (equal? (source-property sexp 'line) 0) - (equal? (source-property sexp 'column) 3)))) + (case (source-property sexp 'column) + ((1) (throw 'unresolved)) + ((3) #t) + (else #f))))) (pass-if "neoteric expression" (let ((sexp (with-read-options '(curly-infix positions) (lambda () (read-string " { f(x) }"))))) (and (equal? (source-property sexp 'line) 0) - (equal? (source-property sexp 'column) 3))))) + (case (source-property sexp 'column) + ((1) (throw 'unresolved)) + ((3) #t) + (else #f)))))) ;; Verify that neoteric expressions are recognized only within curly braces. (pass-if (equal? '(a(x)(y)) '(a (x) (y)))) |