diff options
author | cvs2svn <admin@example.com> | 1996-12-18 21:42:27 +0000 |
---|---|---|
committer | cvs2svn <admin@example.com> | 1996-12-18 21:42:27 +0000 |
commit | 1825e819708b917f0830bee4e9bdf0402b8f338f (patch) | |
tree | 16360e899fbd8729b6e37016227c275701bb0173 | |
parent | 4d46a0279bb9dbe7e7399d6d2f1f54ccac01b987 (diff) | |
download | guile-1825e819708b917f0830bee4e9bdf0402b8f338f.tar.gz |
This commit was manufactured by cvs2svn to create tagpre_jimb_debug
'pre_jimb_debug'.
278 files changed, 0 insertions, 68918 deletions
diff --git a/.cvsignore b/.cvsignore deleted file mode 100644 index 76fb6f31a..000000000 --- a/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -Makefile -config.cache -config.log -config.status -guile-*.tar.gz -config.build-subdirs diff --git a/AUTHORS b/AUTHORS deleted file mode 100644 index 31b837f8d..000000000 --- a/AUTHORS +++ /dev/null @@ -1,57 +0,0 @@ -To find out what should go in this file, see "Information For -Maintainers of GNU Software" (maintain.texi), the section called -"Recording Changes". - - -George Carrette: -wrote files present in Siod version 2.3, released in December of 1989. - -Aubrey Jaffer: -Wrote substantial portions of guile.texi, and surely others. -Changes to: eval.c, ioext.c, posix.c, gscm.c, scm.h, socket.c, -gsubr.c, sys.c, test.scm, stime.c, and unif.c. - -Gary Houston: changes to many files in libguile. -wrote: libguile/socket.c, ice-9/expect.scm - -Tom Lord: Many changes throughout. -In the subdirectory ctax, wrote: - Makefile.in configure.in hashtabs.scm macros.scm scm-ops.scm - c-ops.scm grammar.scm lexer.scm reader.scm -In the subdirectory gtcltk-lib, wrote: - Makefile.in guile-tcl.c guile-tk.c - configure.in guile-tcl.h guile-tk.h -In the subdirectory guile, wrote: - Makefile.in getopt.c getopt1.c - configure.in getopt.h guile.c -In the subdirectory ice-9, wrote: - Makefile.in configure.in lineio.scm poe.scm - boot-9.scm hcons.scm mapping.scm -In the subdirectory lang, wrote: - Makefile.in grammar.scm lr0.scm pp.scm - configure.in lex.scm lr1.scm -In the subdirectory rx, wrote: - Makefile.in runtests.c rxbitset.h rxnfa.c rxspencer.c - TESTS rx.c rxcontext.h rxnfa.h rxspencer.h - TESTS2C.sed rx.h rxcset.c rxnode.c rxstr.c - _rx.h rxall.h rxcset.h rxnode.h rxstr.h - configure.in rxanal.c rxdbug.c rxposix.c rxsuper.c - hashrexp.c rxanal.h rxgnucomp.c rxposix.h rxsuper.h - inst-rxposix.h rxbasic.c rxgnucomp.h rxproto.h rxunfa.c - rgx.c rxbasic.h rxhash.c rxsimp.c rxunfa.h - rgx.h rxbitset.c rxhash.h rxsimp.h testcases.h -In the subdirectory doc, wrote: - ctax.texi gtcltk.texi in.texi lang.texi -and portions of guile.texi. - -Anthony Green: wrote the original code in the 'threads' directory, and -ice-9/threads.scm. - -Mikael Djurfeldt: -In the subdirectory libguile, wrote: - backtrace.c debug.c options.c root.c srcprop.c stacks.c - backtrace.h debug.h options.h root.h srcprop.h stacks.h -In the subdirectory threads, rewrote: - coop-threads.c coop.c mit-pthreads.c threads.c - coop-threads.h fsu-pthreads.h mit-pthreads.h threads.h -Many other changes throughout. diff --git a/COPYING b/COPYING deleted file mode 100644 index 9648fb9ea..000000000 --- a/COPYING +++ /dev/null @@ -1,339 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991, 1992, 1993 Free Software Foundation, Inc. - 675 Mass Ave, Cambridge, MA 02139, USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - Appendix: How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - <one line to give the program's name and a brief idea of what it does.> - Copyright (C) 19yy <name of author> - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) 19yy name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - <signature of Ty Coon>, 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. diff --git a/ChangeLog b/ChangeLog deleted file mode 100644 index 810f294e2..000000000 --- a/ChangeLog +++ /dev/null @@ -1,155 +0,0 @@ -Thu Dec 12 00:14:32 1996 Gary Houston <ghouston@actrix.gen.nz> - - * scsh: new directory. - -Mon Dec 2 17:33:04 1996 Tom Tromey <tromey@cygnus.com> - - * configure.in: Generate doc/guile-programmer/Makefile and - doc/guile-user/Makefile. - -Sat Nov 30 23:45:54 1996 Tom Tromey <tromey@cygnus.com> - - * aclocal.m4: Now automatically generated by aclocal. - * threads.m4: New file. - * guile.m4: New file. - * Makefile.am, doc/Makefile.am: New files. - * configure.in: Updated for Automake. Avoid excessively verbose - "greet" messages. - -Wed Oct 16 07:32:14 1996 Mark Galassi <rosalia@sarastro.lanl.gov> - - * lgh: directory renamed to gh, along with all prefixes of the - high level library procedures. - -Thu Oct 10 14:37:43 1996 Jim Blandy <jimb@floss.cyclic.com> - - * Makefile.in (TAGS tags): Find the source files in $srcdir. - -Wed Oct 9 19:37:14 1996 Jim Blandy <jimb@floss.cyclic.com> - - * Makefile.in (DISTFILES): Add AUTHORS and aclocal.m4. - -Tue Oct 1 00:13:55 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> - - * configure.in: Added some configuration magic from the Cygnus - distribution. - - * aclocal.m4: New file. For now used for thread support - configuration. - -Fri Sep 13 14:39:30 1996 Mark Galassi <rosalia@sarastro.lanl.gov> - - * Makefile.in (DISTFILES): added mkinstalldirs to the DISTFILES - - * PLUGIN: changed the PLUGIN/REQ files in the ice-9 and lgh - directories, to arrange for lgh to the last thing - configured/built. - -Wed Sep 11 21:11:33 1996 Mark Galassi <rosalia@nis.lanl.gov> - - * lgh/: added the directory in which I implement the high level - libguile library (lgh_) for this release of Guile. See the - ChangeLog in there for further details. - -Wed Sep 11 16:12:53 1996 Mark Galassi <rosalia@sarastro.lanl.gov> - - * doc/ (guile-user and guile-programmer): added the guile-user and - guile-programmer directories which contain the user and programmer - manuals. See the ChangeLog entries there for detail. - -Wed Sep 11 14:33:49 1996 Jim Blandy <jimb@floss.cyclic.com> - - * Makefile.in (distclean): Don't forget to delete doc/Makefile. - - * Makefile.in (distclean): Don't forget to delete - config.build-subdirs. - -Thu Sep 5 17:36:15 1996 Jim Blandy <jimb@floss.cyclic.com> - - * Makefile.in (tags): New name for `TAGS' target, which will - always run the commands. - -Thu Sep 5 09:56:50 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * README: Doc fixes. - -Fri Aug 30 16:56:27 1996 Jim Blandy <jimb@floss.cyclic.com> - - * Makefile.in (TAGS): Produce a single tags file for all of Guile. - -Thu Aug 15 19:03:03 1996 Jim Blandy <jimb@floss.cyclic.com> - - * configure.in: Check for -ldl, so the check for Tcl won't fail - spuriously. - -Thu Aug 15 01:29:29 1996 Jim Blandy <jimb@totoro.cyclic.com> - - Change the way we decide whether to build gtcltk-lib, so that it's - omitted from the build process when appropriate, but never from - the dist process. - * configure.in: Don't edit all_subdirs depending on the - availability of Tk; let that be the list of all PLUGIN - subdirectories present, as it used to be. Instead, edit a new - variable, build_subdirs; write its final value, the list of - subdirs we do want to compile in, to config.build-subdirs. - Substitute that into the top-level Makefile too. - * Makefile.in (subdirs): Set this to @build_subdirs@, so we only - recurse on the subdirectories we should build. - (distdirs): Set this to @existingdirs@, so it includes the subdirs - we decided not to build. - - * doc/gtcltk.texi: File resurrected from old Guile releases. - * doc/Makefile.in (info): Build the gtcltk documentation. - (DIST_FILES): Include it in the distribution. - - * configure.in: If we can find the library for tcl7.5, build - gtcltk-lib. Call AC_PROG_CC, to help run that test with the right - compiler (not sure this is necessary). - -Mon Aug 12 15:09:37 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * NEWS: Fix bug reporting address. - -Fri Aug 9 15:58:42 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * AUTHORS: New file, in accordance with the GNU maintainers' - standards. - -Tue Aug 6 14:40:44 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * README: Renamed from ANNOUNCE; include bug report address, - description, and short tour. - * INSTALL: Renamed from BUILDING. - * NEWS: New file. - * Makefile.in (DISTFILES): Update appropriately. - -Thu Aug 1 02:31:53 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * doc/Makefile.in: Added pattern targets for creating DVI and - PostScript files. - (%.ps, %.dvi, %.txt): New targets. - (DVIPS, TEXI2DVI): New variables. - - * GUILE-VERSION: Updated to 1.0b3. - - Rehashed distribution system, in preparation for nightly - snapshots. Other changes in subdirectories. - * Makefile.in (dist): Rewritten --- the old target was out of - date, dependent on files that we don't have, and relied on GNU - tar. The new target is simpler. - (VERSION, srcdir, dist_dirs): New variables. - (DISTFILES): Renamed from localfiles. Added GUILE-VERSION and - TODO. - (localtreats): Variable removed. We don't have this file. - (info): cd to doc and make info there; don't make info in every - ${subdir}; those Makefiles don't know what to do. - (distname, distdir, treats, announcefile): Variables removed. - (manifest-file): Target removed. - (dist-dir): New target, responsible for distributable files in - this directory. - (GZIP, GZIP_EXT, TAR_VERBOSE, DIST_NAME): New variables, - controlling the 'dist' target. - * configure.in: Substitute GUILE-VERSION into the top-level - Makefile. Build doc/Makefile from doc/Makefile.in. - - * doc/Makefile.in: New file. diff --git a/GUILE-VERSION b/GUILE-VERSION deleted file mode 100644 index a8a765d26..000000000 --- a/GUILE-VERSION +++ /dev/null @@ -1,7 +0,0 @@ -GUILE_MAJOR_VERSION=0 -GUILE_MINOR_VERSION=9c -GUILE_VERSION=$GUILE_MAJOR_VERSION.$GUILE_MINOR_VERSION - -# For automake. -VERSION=$GUILE_VERSION -PACKAGE=guile diff --git a/HACKING b/HACKING deleted file mode 100644 index 808fc6694..000000000 --- a/HACKING +++ /dev/null @@ -1,68 +0,0 @@ -Here are some guidelines for working on the Guile source tree at GNU. - -- As for any part of Project GNU, changes to Guile should follow the -GNU coding standards. The standards are available via anonymous FTP -from prep.ai.mit.edu, as /pub/gnu/standards/standards.texi and -make-stds.texi. - -- Check Makefile.in and configure files into CVS, as well as any files -used to create them (Makefile.am, configure.in); don't check in -Makefiles or header files generated by configuration scripts. The -general rule is that you should be able to check out a working -directory of Guile from CVS, and then type "configure" and "make". - -- Make sure your changes compile and work, at least on your own -machine, before checking them into the main branch of the Guile -repository. If you really need to check in untested changes, make a -branch. - -- When you make a user-visible change (i.e. one that should be -documented, and appear in NEWS, put an asterisk in column zero of the -start of the ChangeLog entry, like so: - -Sat Aug 3 01:27:14 1996 Gary Houston <ghouston@actrix.gen.nz> - -* * fports.c (scm_open_file): don't return #f, throw error. - -- Include each log entry in both the ChangeLog and in the CVS logs. -If you're using Emacs, the pcl-cvs interface to CVS has features to -make this easier; it checks the ChangeLog, and generates good default -CVS log entries from that. - -- There's no need to keep a change log for documentation files. This -is because documentation is not susceptible to bugs that are hard to -fix. Documentation does not consist of parts that must interact in a -precisely engineered fashion; to correct an error, you need not know -the history of the erroneous passage. (This is copied from the GNU -coding standards.) - -- If you add or remove files, don't forget to update the appropriate -part of the relevant Makefile.am files, and regenerate the -Makefile.in. If you forget this, the snapshot and distribution -processes will not work. - -- Make sure you have papers from people before integrating their -changes or contributions. This is very frustrating, but very -important to do right. From maintain.texi, "Information for -Maintainers of GNU Software": - - When incorporating changes from other people, make sure to follow the - correct procedures. Doing this ensures that the FSF has the legal - right to distribute and defend GNU software. - - For the sake of registering the copyright on later versions ofthe - software you need to keep track of each person who makes significant - changes. A change of ten lines or so, or a few such changes, in a - large program is not significant. - - *Before* incorporating significant changes, make sure that the person - has signed copyright papers, and that the Free Software Foundation has - received them. - -If you receive contributions you want to use from someone, let me know -and I'll take care of the administrivia. Put the contributions aside -until we have the necessary papers. - - - -Jim Blandy diff --git a/INSTALL b/INSTALL deleted file mode 100644 index dfe41773a..000000000 --- a/INSTALL +++ /dev/null @@ -1,137 +0,0 @@ -To build Guile on unix, there are two basic steps: - - 1. Configure the package by running the configure script. - 2. Build the package by running make. - -Generic instructions for configuring and compiling GNU distributions -are included below. Here is an illustration of commands that might be -used to build Guile. The voluminous output of the commands is not shown. - - % tar xvf guile-snap.tar.gz # unpack the sources - % cd guile-snap - % ./configure - % make - -The `configure' script examines your system, and adapts Guile to -compile and run on it. - -The `make' command builds several things: -- An executable file `guile/guile', which is an interactive shell for - talking with the Guile Scheme interpreter. -- An object library `guile/libguile.a', containing the Guile Scheme - interpreter, ready to be linked into your programs. -- An object library `gtcltk-lib/libgtcltk.a', containing a simple - interface between Guile and Tcl/Tk. This is only built if the - configure script notices that you have the appropriate version of - Tcl/Tk installed on your system already. If it is installed, `make' - will automatically include Tcl/Tk and the interface in the guile - shell. If the interface were documented, we'd include a pointer to - it here. - -To install Guile, type `make install'. This installs the executable -and libraries mentioned above, as well as Guile's header files and -Scheme libraries. - -If you want to run Guile without installing it, set the environment -variable `SCHEME_LOAD_PATH' to a colon-separated list of directories, -including the directory containing this INSTALL file. For example, if -you unpacked Guile so that the full filename of this file is -`/home/jimb/guile-snap/INSTALL', then you might say - - export SCHEME_LOAD_PATH=/home/jimb/my-scheme:/home/jimb/guile-snap - -if you're using Bash or any other Bourne shell variant, or - - setenv SCHEME_LOAD_PATH /home/jimb/my-scheme:/home/jimb/guile-snap - -if you're using CSH or one of its variants. - - - Generic Instructions for Building Auto-Configured Packages - ========================================================== - - -To compile this package: - -1. Configure the package for your system. In the directory that this -file is in, type `./configure'. If you're using `csh' on an old -version of System V, you might need to type `sh configure' instead to -prevent `csh' from trying to execute `configure' itself. - -The `configure' shell script attempts to guess correct values for -various system-dependent variables used during compilation, and -creates the Makefile(s) (one in each subdirectory of the source -directory). In some packages it creates a C header file containing -system-dependent definitions. It also creates a file `config.status' -that you can run in the future to recreate the current configuration. -Running `configure' takes a minute or two. - -To compile the package in a different directory from the one -containing the source code, you must use GNU make. `cd' to the -directory where you want the object files and executables to go and -run `configure' with the option `--srcdir=DIR', where DIR is the -directory that contains the source code. Using this option is -actually unnecessary if the source code is in the parent directory of -the one in which you are compiling; `configure' automatically checks -for the source code in `..' if it does not find it in the current -directory. - -By default, `make install' will install the package's files in -/usr/local/bin, /usr/local/lib, /usr/local/man, etc. You can specify -an installation prefix other than /usr/local by giving `configure' the -option `--prefix=PATH'. Alternately, you can do so by changing the -`prefix' variable in the Makefile that `configure' creates (the -Makefile in the top-level directory, if the package contains -subdirectories). - -You can specify separate installation prefixes for machine-specific -files and machine-independent files. If you give `configure' the -option `--exec_prefix=PATH', the package will use PATH as the prefix -for installing programs and libraries. Normally, all files are -installed using the same prefix. - -`configure' ignores any other arguments that you give it. - -If your system requires unusual options for compilation or linking -that `configure' doesn't know about, you can give `configure' initial -values for some variables by setting them in the environment. In -Bourne-compatible shells, you can do that on the command line like -this: - CC='gcc -traditional' DEFS=-D_POSIX_SOURCE ./configure - -The `make' variables that you might want to override with environment -variables when running `configure' are: - -(For these variables, any value given in the environment overrides the -value that `configure' would choose:) -CC C compiler program. - Default is `cc', or `gcc' if `gcc' is in your PATH. -INSTALL Program to use to install files. - Default is `install' if you have it, `cp' otherwise. -INCLUDEDIR Directory for `configure' to search for include files. - Default is /usr/include. - -(For these variables, any value given in the environment is added to -the value that `configure' chooses:) -DEFS Configuration options, in the form '-Dfoo -Dbar ...' -LIBS Libraries to link with, in the form '-lfoo -lbar ...' - -If you need to do unusual things to compile the package, we encourage -you to teach `configure' how to do them and mail the diffs to the -address given in the README so we can include them in the next -release. - -2. Type `make' to compile the package. - -3. Type `make install' to install programs, data files, and -documentation. - -4. You can remove the program binaries and object files from the -source directory by typing `make clean'. To also remove the -Makefile(s), the header file containing system-dependent definitions -(if the package uses one), and `config.status' (all the files that -`configure' created), type `make distclean'. - -The file `configure.in' is used as a template to create `configure' by -a program called `autoconf'. You will only need it if you want to -regenerate `configure' using a newer version of `autoconf'. diff --git a/Makefile.am b/Makefile.am deleted file mode 100644 index efe9ec547..000000000 --- a/Makefile.am +++ /dev/null @@ -1,14 +0,0 @@ -## Process this file with automake to produce Makefile.in. - -SUBDIRS = @existingdirs@ doc - -guile_dirs = @existingdirs@ doc -guile-dist: - $(MAKE) SUBDIRS="$(guile_dirs)" dist - -## FIXME: in the future there will be direct automake support for -## doing this. When that happens, switch over. -aclocaldir = $(datadir)/aclocal -aclocal_DATA = guile.m4 threads.m4 - -EXTRA_DIST = $(aclocal_DATA) HACKING GUILE-VERSION diff --git a/Makefile.in b/Makefile.in deleted file mode 100644 index 999e68056..000000000 --- a/Makefile.in +++ /dev/null @@ -1,262 +0,0 @@ -# Makefile.in generated automatically by automake 1.1l from Makefile.am - -# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. -# This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - - -SHELL = /bin/sh - -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -VPATH = @srcdir@ -prefix = @prefix@ -exec_prefix = @exec_prefix@ - -bindir = @bindir@ -sbindir = @sbindir@ -libexecdir = @libexecdir@ -datadir = @datadir@ -sysconfdir = @sysconfdir@ -sharedstatedir = @sharedstatedir@ -localstatedir = @localstatedir@ -libdir = @libdir@ -infodir = @infodir@ -mandir = @mandir@ -includedir = @includedir@ -oldincludedir = /usr/include - -pkgdatadir = $(datadir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ - -top_builddir = . - -INSTALL = @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -transform = @program_transform_name@ -VERSION = @VERSION@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -PACKAGE = @PACKAGE@ -existingdirs = @existingdirs@ - -SUBDIRS = @existingdirs@ doc - -guile_dirs = @existingdirs@ doc - -aclocaldir = $(datadir)/aclocal -aclocal_DATA = guile.m4 threads.m4 - -EXTRA_DIST = $(aclocal_DATA) HACKING GUILE-VERSION -ACLOCAL = $(top_srcdir)/aclocal.m4 -mkinstalldirs = $(SHELL) $(top_srcdir)/mkinstalldirs -CONFIG_CLEAN_FILES = -DATA = $(aclocal_DATA) - -DIST_COMMON = README AUTHORS COPYING ChangeLog INSTALL Makefile.am \ -Makefile.in NEWS README TODO aclocal.m4 config.guess config.sub \ -configure configure.in install-sh mdate-sh mkinstalldirs - - -DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \ - $(TEXINFOS) $(MANS) $(EXTRA_DIST) - -TAR = tar -default: all - -.SUFFIXES: -$(srcdir)/Makefile.in: Makefile.am $(top_srcdir)/configure.in $(ACLOCAL) - cd $(top_srcdir) && automake --gnu Makefile - -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES) - cd $(top_builddir) \ - && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status - -$(srcdir)/aclocal.m4: configure.in - cd $(srcdir) && aclocal - -config.status: configure - $(SHELL) ./config.status --recheck -$(srcdir)/configure: configure.in $(ACLOCAL) $(CONFIGURE_DEPENDENCIES) - cd $(srcdir) && autoconf - -install-aclocalDATA: $(aclocal_DATA) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(aclocaldir) - @list="$(aclocal_DATA)"; for p in $$list; do \ - if test -f $(srcdir)/$$p; then \ - echo "$(INSTALL_DATA) $(srcdir)/$$p $(aclocaldir)/$$p"; \ - $(INSTALL_DATA) $(srcdir)/$$p $(aclocaldir)/$$p; \ - else if test -f $$p; then \ - echo "$(INSTALL_DATA) $$p $(aclocaldir)/$$p"; \ - $(INSTALL_DATA) $$p $(aclocaldir)/$$p; \ - fi; fi; \ - done - -uninstall-aclocalDATA: - list="$(aclocal_DATA)"; for p in $$list; do \ - rm -f $(aclocaldir)/$$p; \ - done - -# This directory's subdirectories are mostly independent; you can cd -# into them and run `make' without going through this Makefile. -# To change the values of `make' variables: instead of editing Makefiles, -# (1) if the variable is set in `config.status', edit `config.status' -# (which will cause the Makefiles to be regenerated when you run `make'); -# (2) otherwise, pass the desired values on the `make' command line. - -@SET_MAKE@ - -all-recursive install-data-recursive install-exec-recursive \ -installdirs-recursive install-recursive uninstall-recursive \ -check-recursive installcheck-recursive info-recursive dvi-recursive \ -mostlyclean-recursive clean-recursive distclean-recursive \ -maintainer-clean-recursive: - @for subdir in $(SUBDIRS); do \ - target=`echo $@ | sed s/-recursive//`; \ - echo "Making $$target in $$subdir"; \ - (cd $$subdir && $(MAKE) $$target) \ - || case "$(MFLAGS)" in *k*) fail=yes;; *) exit 1;; esac; \ - done && test -z "$$fail" -tags-recursive: - list="$(SUBDIRS)"; for subdir in $$list; do \ - (cd $$subdir && $(MAKE) tags); \ - done -tags: TAGS -TAGS: - - -distdir = $(PACKAGE)-$(VERSION) -# This target untars the dist file and tries a VPATH configuration. Then -# it guarantees that the distribution is self-contained by making another -# tarfile. -distcheck: dist - rm -rf $(distdir) - $(TAR) zxf $(distdir).tar.gz - mkdir $(distdir)/=build - mkdir $(distdir)/=inst - dc_install_base=`cd $(distdir)/=inst && pwd`; \ - cd $(distdir)/=build \ - && ../configure --srcdir=.. --prefix=$$dc_install_base \ - && $(MAKE) \ - && $(MAKE) dvi \ - && $(MAKE) check \ - && $(MAKE) install \ - && $(MAKE) installcheck \ - && $(MAKE) dist - rm -rf $(distdir) - @echo "========================"; \ - echo "$(distdir).tar.gz is ready for distribution"; \ - echo "========================" -dist: distdir - -chmod -R a+r $(distdir) - $(TAR) chozf $(distdir).tar.gz $(distdir) - rm -rf $(distdir) -dist-all: distdir - -chmod -R a+r $(distdir) - $(TAR) chozf $(distdir).tar.gz $(distdir) - rm -rf $(distdir) -distdir: $(DISTFILES) - rm -rf $(distdir) - mkdir $(distdir) - -chmod 755 $(distdir) - here=`pwd`; distdir=`cd $(distdir) && pwd` \ - && cd $(srcdir) \ - && automake --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --gnu - @for file in $(DISTFILES); do \ - d=$(srcdir); \ - test -f $(distdir)/$$file \ - || ln $$d/$$file $(distdir)/$$file 2> /dev/null \ - || cp -p $$d/$$file $(distdir)/$$file; \ - done - for subdir in $(SUBDIRS); do \ - test -d $(distdir)/$$subdir \ - || mkdir $(distdir)/$$subdir \ - || exit 1; \ - chmod 755 $(distdir)/$$subdir; \ - (cd $$subdir && $(MAKE) distdir=../$(distdir)/$$subdir distdir) \ - || exit 1; \ - done -info: info-recursive -dvi: dvi-recursive -check: all-am - $(MAKE) check-recursive -installcheck: installcheck-recursive -all-am: $(DATA) Makefile - -install-data-am: install-aclocalDATA - -uninstall-am: uninstall-aclocalDATA - -install-exec: install-exec-recursive - $(NORMAL_INSTALL) - -install-data: install-data-recursive install-data-am - $(NORMAL_INSTALL) - -install: install-recursive install-data-am - @: - -uninstall: uninstall-recursive uninstall-am - -all: all-recursive all-am - -install-strip: - $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install -installdirs: installdirs-recursive - $(mkinstalldirs) $(aclocaldir) - - -mostlyclean-generic: - test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) - -clean-generic: - test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) - -distclean-generic: - rm -f Makefile $(DISTCLEANFILES) - rm -f config.cache config.log stamp-h - test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -maintainer-clean-generic: - test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) - test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) -mostlyclean-am: mostlyclean-generic - -clean-am: clean-generic mostlyclean-am - -distclean-am: distclean-generic clean-am - -maintainer-clean-am: maintainer-clean-generic distclean-am - -mostlyclean: mostlyclean-am mostlyclean-recursive - -clean: clean-am clean-recursive - -distclean: distclean-am distclean-recursive - rm -f config.status - -maintainer-clean: maintainer-clean-am maintainer-clean-recursive - @echo "This command is intended for maintainers to use;" - @echo "it deletes files that may require special tools to rebuild." - rm -f config.status - -.PHONY: default uninstall-aclocalDATA install-aclocalDATA \ -install-data-recursive uninstall-data-recursive install-exec-recursive \ -uninstall-exec-recursive installdirs-recursive uninstalldirs-recursive \ -all-recursive check-recursive installcheck-recursive info-recursive \ -dvi-recursive mostlyclean-recursive distclean-recursive clean-recursive \ -maintainer-clean-recursive tags tags-recursive distdir info dvi \ -installcheck all-am install-data-am uninstall-am install-exec \ -install-data install uninstall all installdirs mostlyclean-generic \ -distclean-generic clean-generic maintainer-clean-generic clean \ -mostlyclean distclean maintainer-clean - -guile-dist: - $(MAKE) SUBDIRS="$(guile_dirs)" dist - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: @@ -1,175 +0,0 @@ -Guile NEWS --- history of user-visible changes. 2 Aug 1996 -*- text -*- -Copyright (C) 1996 Free Software Foundation, Inc. -See the end for copying conditions. - -Please send Guile bug reports to bug-guile@prep.ai.mit.edu. - -Guile 1.0b3 - -Changes since Thursday, September 5: - - -* Guile now distinguishes between #f and the empty list. - -This is for compatibility with the IEEE standard, the (possibly) -upcoming Revised^5 Report on Scheme, and many extant Scheme -implementations. - -Guile used to have #f and '() denote the same object, to make Scheme's -type system more compatible with Emacs Lisp's. However, the change -caused too much trouble for Scheme programmers, and we found another -way to reconcile Emacs Lisp with Scheme that didn't require this. - -* You can now use Guile as a shell script interpreter. - -To paraphrase the SCSH manual: - - When Unix tries to execute an executable file whose first two - characters are the `#!', it treats the file not as machine code to - be directly executed by the native processor, but as source code - to be executed by some interpreter. The interpreter to use is - specified immediately after the #! sequence on the first line of - the source file. The kernel reads in the name of the interpreter, - and executes that instead. It passes the interpreter the source - filename as its first argument, with the original arguments - following. Consult the Unix man page for the `exec' system call - for more information. - -Now you can use Guile as an interpreter, using a mechanism which is a -compatible subset of that provided by SCSH. - -Guile now recognizes a '-s' command line switch, whose argument is the -name of a file of Scheme code to load. It also treats the two -characters `#!' as the start of a comment, terminated by `!#'. Thus, -to make a file of Scheme code directly executable by Unix, insert the -following two lines at the top of the file: - -#!/usr/local/bin/guile -s -!# - -Guile treats the argument of the `-s' command-line switch as the name -of a file of Scheme code to load, and treats the sequence `#!' as the -start of a block comment, terminated by `!#'. - -For example, here's a version of 'echo' written in Scheme: - -#!/usr/local/bin/guile -s -!# -(let loop ((args (cdr (program-arguments)))) - (if (pair? args) - (begin - (display (car args)) - (if (pair? (cdr args)) - (display " ")) - (loop (cdr args))))) -(newline) - -Why does `#!' start a block comment terminated by `!#', instead of the -end of the line? That is the notation SCSH uses, and although we -don't yet support the other SCSH features that motivate that choice, -we would like to be backward-compatible with any existing Guile -scripts once we do. Furthermore, if the path to Guile on your system -is too long for your kernel, you can start the script with this -horrible hack: - -#!/bin/sh -exec /really/long/path/to/guile -s "$0" ${1+"$@"} -!# - -Note that some very old Unix systems don't support the `#!' syntax. - -* You can now run Guile without installing it. - -Previous versions of the interactive Guile interpreter (`guile') -couldn't start up unless Guile's Scheme library had been installed; -they used the value of the environment variable `SCHEME_LOAD_PATH' -later on in the startup process, but not to find the startup code -itself. Now Guile uses `SCHEME_LOAD_PATH' in all searches for Scheme -code. - -To run Guile without installing it, build it in the normal way, and -then set the environment variable `SCHEME_LOAD_PATH' to a -colon-separated list of directories, including the top-level directory -of the Guile sources. For example, if you unpacked Guile so that the -full filename of this NEWS file is /home/jimb/guile-1.0b3/NEWS, then -you might say - - export SCHEME_LOAD_PATH=/home/jimb/my-scheme:/home/jimb/guile-1.0b3 - -* Guile's header files should no longer conflict with your system's -header files. - -In order to compile code which #included <libguile.h>, previous -versions of Guile required you to add a directory containing all the -Guile header files to your #include path. This was a problem, since -Guile's header files have names which conflict with many systems' -header files. - -Now only <libguile.h> need appear in your #include path; you must -refer to all Guile's other header files as <libguile/mumble.h>. -Guile's installation procedure puts libguile.h in $(includedir), and -the rest in $(includedir)/libguile. - -* The compiled-library-path function has been deleted from libguile. - -* A variable and two new functions have been added to libguile: - -** The variable %load-path now tells Guile which directories to search -for Scheme code. Its value is a list of strings, each of which names -a directory. - -** (%search-load-path FILENAME) searches the directories listed in the -value of the %load-path variable for a Scheme file named FILENAME. If -it finds a match, then it returns its full filename. Otherwise, it -returns #f. %search-load-path will not return matches that refer to -directories. - -** (%try-load-path FILENAME :optional CASE-INSENSITIVE-P SHARP) -searches the directories listed in %load-path for a file named -FILENAME, and loads it if it finds it. If it can't read FILENAME for -any reason, it throws an error. - -The arguments CASE-INSENSITIVE-P and SHARP are interpreted as by the -%try-load function. - - -Older changes: - -* Guile no longer includes sophisticated Tcl/Tk support. - -The old Tcl/Tk support was unsatisfying to us, because it required the -user to link against the Tcl library, as well as Tk and Guile. The -interface was also un-lispy, in that it preserved Tcl/Tk's practice of -referring to widgets by names, rather than exporting widgets to Scheme -code as a special datatype. - -In the Usenix Tk Developer's Workshop held in July 1996, the Tcl/Tk -maintainers described some very interesting changes in progress to the -Tcl/Tk internals, which would facilitate clean interfaces between lone -Tk and other interpreters --- even for garbage-collected languages -like Scheme. They expected the new Tk to be publicly available in the -fall of 1996. - -Since it seems that Guile might soon have a new, cleaner interface to -lone Tk, and that the old Guile/Tk glue code would probably need to be -completely rewritten, we (Jim Blandy and Richard Stallman) have -decided not to support the old code. We'll spend the time instead on -a good interface to the newer Tk, as soon as it is available. - -Until then, gtcltk-lib provides trivial, low-maintenance functionality. - - -Copyright information: - -Copyright (C) 1996 Free Software Foundation, Inc. - - Permission is granted to anyone to make or distribute verbatim copies - of this document as received, in any medium, provided that the - copyright notice and this permission notice are preserved, - thus giving the recipient permission to redistribute in turn. - - Permission is granted to distribute modified versions - of this document, or of portions of it, - under the above conditions, provided also that they - carry prominent notices stating who last changed them. - diff --git a/README b/README deleted file mode 100644 index 3bb8fafb4..000000000 --- a/README +++ /dev/null @@ -1,97 +0,0 @@ -This is a nightly snapshot of Guile, a portable, embeddable Scheme -implementation written in C. Guile provides a machine independent -execution platform that can be linked in as a library when building -extensible programs. - -Please send bug reports to bug-guile@prep.ai.mit.edu. - - -Important Facts About Snapshots ====================================== - - Please keep in mind that these sources are strictly experimental; - they will usually not be well-tested, and may not even compile on - some systems. They may contain interfaces which will change. - They will usually not be of sufficient quality for use by people - not comfortable hacking the innards of Guile. Caveat! - - However, we're providing them anyway for several reasons. We'd like - to encourage people to get involved in developing Guile. People - willing to use the bleeding edge of development can get earlier access - to new, experimental features. Patches submitted relative to recent - snapshots will be easier for us to evaluate and install, since the - patch's original sources will be closer to what we're working with. - And it allows us to start testing features earlier. - -The Guile snapshots are available via anonymous FTP from -alpha.gnu.ai.mit.edu, as /gnu/guile-snap.tar.gz. - -Via the web, that's: ftp://alpha.gnu.ai.mit.edu/gnu/guile-snap.tar.gz -For getit, that's: alpha.gnu.ai.mit.edu:/gnu/guile-snap.tar.gz - - -Contents Of This Distribution ======================================== - -Interesting files include: -- INSTALL, which contains instructions on building and installing Guile. -- NEWS, which describes user-visible changes since the last release of Guile. -- COPYING, which describes the terms under which you may redistribute - Guile, and explains that there is no warranty. - -The Guile source tree is laid out as follows: - -doc: Documentation for Guile, in Texinfo form. -libguile: - The Guile Scheme interpreter, packaged as an object library - for you to link with your programs. -guile: An interactive front end for the Guile Scheme interpreter. -rx: A regular expression matching library, interfaced to Guile. -ice-9: Guile's module system, initialization code, and other infrastructure. -lang: A Guile module of tools for writing lexical analyzers and parsers. -ctax: A Guile module providing a C-like syntax for Scheme. -gtcltk-lib: - Glue code for talking to Tcl/Tk from Guile. The Tcl/Tk - developers have big plans for the next major release of Tcl/Tk - which will make possible a clean, direct interface between - Guile and Tk, so we're providing this very simple-minded - interface until that's ready. -threads: Glue code for using various threads packages from Guile, including - qt (see below). - -This distribution also includes `qt', a cooperative threads package -from Washington University, which Guile can use. Qt is under a -separate copyright; see `qt/README' for more details. - -The mailing list `guile@cygnus.com' carries discussions, questions, -and often answers, about Guile. To subscribe, send mail to -guile-request@cygnus.com. Of course, please send bug reports (and -fixes!) to bug-guile@prep.ai.mit.edu. - - -Authors And Contributors ============================================= - -George Carrette wrote SIOD, a stand-alone scheme interpreter. -Although most of this code as been rewritten or replaced over time, -the garbage collector from SIOD is still an important part of Guile. - -Aubrey Jaffer seriously tuned performance and added features. He -designed many hairy parts of the tag system and evaluator. - -Tom Lord librarified SCM, yielding Guile. He wrote Guile's operating -system, Ice-9, and connected Guile to Tcl/Tk and the `rx' regular -expression matcher. - -Gary Houston wrote the Unix system call support, including the socket -support. - -Anthony Green wrote the original version of `threads' the interface -between Guile and qt. - -Mikael Djurfeldt designed and implemented: -* the source-level debugger, -* stack overflow detection, -* the GDB patches to support debugging mixed Scheme/C code, -* the original implementation of weak hash tables, -* the `threads' interface (rewriting Anthony Green's work), and -* detection of circular references during printing. - -Gary Houston did a lot of work on the error handling code. @@ -1,42 +0,0 @@ -Needed before release - -* Add facilities for debugging Scheme programs. - -Mikael Djurfeldt <mdj@nada.kth.se> is working on this. The low-level -functions are available, but need a user interface. He has also -written extensisons to GDB to allow it to print lispy values in lispy -notation when debugging Guile's C code. - -* Merge in the Cygnus threads package. - -This is done, but needs debugging. - -* Documentation. - -They should be complete and accurate. They should also have more -general explanation (right now they're strictly reference), but -perhaps that will have to wait until after the first release. - - -Desired later on - -* Good interface to Tk - -* Add a convenient facility for running a pipeline of processes -with redirections. Gary Houston <ghouston@actrix.gen.nz> -is working on this. - -* Make it possible to link Guile and TK without using libtcl.a, by -providing Guile-based replacements for the libtcl.a functions that TK -requires. - -* Make ordinary lambda functions work as callbacks for Tk; -eliminate the need for tcl-lambda. - -* Translators for additional languages; in particular, Perl, Python, -TCL, Emacs Lisp, and Rexx. - -* Clean up declarations of C functions to use a PROTO macro -for conditional prototypes, instead of explicit conditionals. - -* A package for time conversions and formatting. diff --git a/aclocal.m4 b/aclocal.m4 deleted file mode 100644 index e18720fd8..000000000 --- a/aclocal.m4 +++ /dev/null @@ -1,52 +0,0 @@ -dnl aclocal.m4 generated automatically by aclocal 1.1l - -# Do all the work for Automake. This macro actually does too much -- -# some checks are only needed if your package does certain things. -# But this isn't really a big deal. - -# serial 1 - -dnl Usage: -dnl AM_INIT_AUTOMAKE(package,version) - -AC_DEFUN(AM_INIT_AUTOMAKE, -[AC_REQUIRE([AM_PROG_INSTALL]) -PACKAGE=[$1] -AC_SUBST(PACKAGE) -AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE") -VERSION=[$2] -AC_SUBST(VERSION) -AC_DEFINE_UNQUOTED(VERSION, "$VERSION") -AM_SANITY_CHECK -AC_ARG_PROGRAM -AC_PROG_MAKE_SET]) - - -# serial 1 - -AC_DEFUN(AM_PROG_INSTALL, -[AC_REQUIRE([AC_PROG_INSTALL]) -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' -AC_SUBST(INSTALL_SCRIPT)dnl -]) - -# -# Check to make sure that the build environment is sane. -# - -AC_DEFUN(AM_SANITY_CHECK, -[AC_MSG_CHECKING([whether build environment is sane]) -echo timestamp > conftestfile -# Do this in a subshell so we don't clobber the current shell's -# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? -if (set X `ls -t $srcdir/configure conftestfile`; test "[$]2" = conftestfile) -then - # Ok. - : -else - AC_MSG_ERROR([newly created file is older than distributed files! -Check your system clock]) -fi -rm -f conftest* -AC_MSG_RESULT(yes)]) - diff --git a/config.guess b/config.guess deleted file mode 100755 index a3d6a9f1b..000000000 --- a/config.guess +++ /dev/null @@ -1,497 +0,0 @@ -#! /bin/sh -# Attempt to guess a canonical system name. -# Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. -# -# This file is free software; you can redistribute it and/or modify it -# under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -# -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - -# Written by Per Bothner <bothner@cygnus.com>. -# The master version of this file is at the FSF in /home/gd/gnu/lib. -# -# This script attempts to guess a canonical system name similar to -# config.sub. If it succeeds, it prints the system name on stdout, and -# exits with 0. Otherwise, it exits with 1. -# -# The plan is that this can be called by configure scripts if you -# don't specify an explicit system type (host/target name). -# -# Only a few systems have been added to this list; please add others -# (but try to keep the structure clean). -# - -# This is needed to find uname on a Pyramid OSx when run in the BSD universe. -# (ghazi@noc.rutgers.edu 8/24/94.) -if (test -f /.attbin/uname) >/dev/null 2>&1 ; then - PATH=$PATH:/.attbin ; export PATH -fi - -UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown -UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown -UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown -UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown - -trap 'rm -f dummy.c dummy.o dummy; exit 1' 1 2 15 - -# Note: order is significant - the case branches are not exclusive. - -case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in - alpha:OSF1:V*:*) - # After 1.2, OSF1 uses "V1.3" for uname -r. - echo alpha-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^V//'` - exit 0 ;; - alpha:OSF1:*:*) - # 1.2 uses "1.2" for uname -r. - echo alpha-dec-osf${UNAME_RELEASE} - exit 0 ;; - amiga:NetBSD:*:*) - echo m68k-cbm-netbsd${UNAME_RELEASE} - exit 0 ;; - arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) - echo arm-acorn-riscix${UNAME_RELEASE} - exit 0;; - Pyramid*:OSx*:*:*) - if test "`(/bin/universe) 2>/dev/null`" = att ; then - echo pyramid-pyramid-sysv3 - else - echo pyramid-pyramid-bsd - fi - exit 0 ;; - sun4*:SunOS:5.*:*) - echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - sun4*:SunOS:6*:*) - # According to config.sub, this is the proper way to canonicalize - # SunOS6. Hard to guess exactly what SunOS6 will be like, but - # it's likely to be more like Solaris than SunOS4. - echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` - exit 0 ;; - sun4*:SunOS:*:*) - case "`/usr/bin/arch -k`" in - Series*|S4*) - UNAME_RELEASE=`uname -v` - ;; - esac - # Japanese Language versions have a version number like `4.1.3-JL'. - echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` - exit 0 ;; - sun3*:SunOS:*:*) - echo m68k-sun-sunos${UNAME_RELEASE} - exit 0 ;; - RISC*:ULTRIX:*:*) - echo mips-dec-ultrix${UNAME_RELEASE} - exit 0 ;; - VAX*:ULTRIX*:*:*) - echo vax-dec-ultrix${UNAME_RELEASE} - exit 0 ;; - mips:*:5*:RISCos) - echo mips-mips-riscos${UNAME_RELEASE} - exit 0 ;; - m88k:CX/UX:7*:*) - echo m88k-harris-cxux7 - exit 0 ;; - m88k:*:4*:R4*) - echo m88k-motorola-sysv4 - exit 0 ;; - m88k:*:3*:R3*) - echo m88k-motorola-sysv3 - exit 0 ;; - AViiON:dgux:*:*) - if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx \ - -o ${TARGET_BINARY_INTERFACE}x = x ] ; then - echo m88k-dg-dgux${UNAME_RELEASE} - else - echo m88k-dg-dguxbcs${UNAME_RELEASE} - fi - exit 0 ;; - M88*:DolphinOS:*:*) # DolphinOS (SVR3) - echo m88k-dolphin-sysv3 - exit 0 ;; - M88*:*:R3*:*) - # Delta 88k system running SVR3 - echo m88k-motorola-sysv3 - exit 0 ;; - XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) - echo m88k-tektronix-sysv3 - exit 0 ;; - Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) - echo m68k-tektronix-bsd - exit 0 ;; - *:IRIX*:*:*) - echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` - exit 0 ;; - ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. - echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id - exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX ' - i[34]86:AIX:*:*) - echo i386-ibm-aix - exit 0 ;; - *:AIX:2:3) - if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then - sed 's/^ //' << EOF >dummy.c - #include <sys/systemcfg.h> - - main() - { - if (!__power_pc()) - exit(1); - puts("powerpc-ibm-aix3.2.5"); - exit(0); - } -EOF - ${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0 - rm -f dummy.c dummy - echo rs6000-ibm-aix3.2.5 - elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then - echo rs6000-ibm-aix3.2.4 - else - echo rs6000-ibm-aix3.2 - fi - exit 0 ;; - *:AIX:*:4) - if /usr/sbin/lsattr -EHl proc0 | grep POWER >/dev/null 2>&1; then - IBM_ARCH=rs6000 - else - IBM_ARCH=powerpc - fi - if grep bos410 /usr/include/stdio.h >/dev/null 2>&1; then - IBM_REV=4.1 - elif grep bos411 /usr/include/stdio.h >/dev/null 2>&1; then - IBM_REV=4.1.1 - else - IBM_REV=4.${UNAME_RELEASE} - fi - echo ${IBM_ARCH}-ibm-aix${IBM_REV} - exit 0 ;; - *:AIX:*:*) - echo rs6000-ibm-aix - exit 0 ;; - ibmrt:4.4BSD:*|romp-ibm:BSD:*) - echo romp-ibm-bsd4.4 - exit 0 ;; - ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC NetBSD and - echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to - exit 0 ;; # report: romp-ibm BSD 4.3 - *:BOSX:*:*) - echo rs6000-bull-bosx - exit 0 ;; - DPX/2?00:B.O.S.:*:*) - echo m68k-bull-sysv3 - exit 0 ;; - 9000/[34]??:4.3bsd:1.*:*) - echo m68k-hp-bsd - exit 0 ;; - hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) - echo m68k-hp-bsd4.4 - exit 0 ;; - 9000/[3478]??:HP-UX:*:*) - case "${UNAME_MACHINE}" in - 9000/31? ) HP_ARCH=m68000 ;; - 9000/[34]?? ) HP_ARCH=m68k ;; - 9000/7?? | 9000/8?7 ) HP_ARCH=hppa1.1 ;; - 9000/8?? ) HP_ARCH=hppa1.0 ;; - esac - HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` - echo ${HP_ARCH}-hp-hpux${HPUX_REV} - exit 0 ;; - 3050*:HI-UX:*:*) - sed 's/^ //' << EOF >dummy.c - #include <unistd.h> - int - main () - { - long cpu = sysconf (_SC_CPU_VERSION); - /* The order matters, because CPU_IS_HP_MC68K erroneously returns - true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct - results, however. */ - if (CPU_IS_PA_RISC (cpu)) - { - switch (cpu) - { - case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; - case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; - case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; - default: puts ("hppa-hitachi-hiuxwe2"); break; - } - } - else if (CPU_IS_HP_MC68K (cpu)) - puts ("m68k-hitachi-hiuxwe2"); - else puts ("unknown-hitachi-hiuxwe2"); - exit (0); - } -EOF - ${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0 - rm -f dummy.c dummy - echo unknown-hitachi-hiuxwe2 - exit 0 ;; - 9000/7??:4.3bsd:*:* | 9000/8?7:4.3bsd:*:* ) - echo hppa1.1-hp-bsd - exit 0 ;; - 9000/8??:4.3bsd:*:*) - echo hppa1.0-hp-bsd - exit 0 ;; - hp7??:OSF1:*:* | hp8?7:OSF1:*:* ) - echo hppa1.1-hp-osf - exit 0 ;; - hp8??:OSF1:*:*) - echo hppa1.0-hp-osf - exit 0 ;; - C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) - echo c1-convex-bsd - exit 0 ;; - C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit 0 ;; - C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) - echo c34-convex-bsd - exit 0 ;; - C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) - echo c38-convex-bsd - exit 0 ;; - C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) - echo c4-convex-bsd - exit 0 ;; - CRAY*X-MP:UNICOS:*:*) - echo xmp-cray-unicos - exit 0 ;; - CRAY*Y-MP:UNICOS:*:*) - echo ymp-cray-unicos - exit 0 ;; - CRAY-2:UNICOS:*:*) - echo cray2-cray-unicos - exit 0 ;; - hp3[0-9][05]:NetBSD:*:*) - echo m68k-hp-netbsd${UNAME_RELEASE} - exit 0 ;; - i[34]86:BSD/386:*:* | *:BSD/OS:*:*) - echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} - exit 0 ;; - *:FreeBSD:*:*) - echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` - exit 0 ;; - *:NetBSD:*:*) - echo ${UNAME_MACHINE}-unknown-netbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` - exit 0 ;; - *:GNU:*:*) - echo `echo ${UNAME_MACHINE}|sed -e 's,/.*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` - exit 0 ;; - *:Linux:*:*) - echo ${UNAME_MACHINE}-unknown-linux - exit 0 ;; -# ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. earlier versions -# are messed up and put the nodename in both sysname and nodename. - i[34]86:DYNIX/ptx:4*:*) - echo i386-sequent-sysv4 - exit 0 ;; - i[34]86:*:4.*:* | i[34]86:SYSTEM_V:4.*:*) - if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then - echo ${UNAME_MACHINE}-univel-sysv${UNAME_RELEASE} - else - echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE} - fi - exit 0 ;; - i[34]86:*:3.2:*) - if test -f /usr/options/cb.name; then - UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name` - echo ${UNAME_MACHINE}-unknown-isc$UNAME_REL - elif /bin/uname -X 2>/dev/null >/dev/null ; then - UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')` - (/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486 - echo ${UNAME_MACHINE}-unknown-sco$UNAME_REL - else - echo ${UNAME_MACHINE}-unknown-sysv32 - fi - exit 0 ;; - Intel:Mach:3*:*) - echo i386-unknown-mach3 - exit 0 ;; - paragon:*:*:*) - echo i860-intel-osf1 - exit 0 ;; - i860:*:4.*:*) # i860-SVR4 - if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then - echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 - else # Add other i860-SVR4 vendors below as they are discovered. - echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 - fi - exit 0 ;; - mini*:CTIX:SYS*5:*) - # "miniframe" - echo m68010-convergent-sysv - exit 0 ;; - M680[234]0:*:R3V[567]*:*) - test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;; - 3[34]??:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0) - uname -p 2>/dev/null | grep 86 >/dev/null \ - && echo i486-ncr-sysv4.3 && exit 0 ;; - 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) - uname -p 2>/dev/null | grep 86 >/dev/null \ - && echo i486-ncr-sysv4 && exit 0 ;; - m680[234]0:LynxOS:2.2*:*) - echo m68k-lynx-lynxos${UNAME_RELEASE} - exit 0 ;; - mc68030:UNIX_System_V:4.*:*) - echo m68k-atari-sysv4 - exit 0 ;; - i[34]86:LynxOS:2.2*:*) - echo i386-lynx-lynxos${UNAME_RELEASE} - exit 0 ;; - TSUNAMI:LynxOS:2.2*:*) - echo sparc-lynx-lynxos${UNAME_RELEASE} - exit 0 ;; - rs6000:LynxOS:2.2*:*) - echo rs6000-lynx-lynxos${UNAME_RELEASE} - exit 0 ;; - RM*:SINIX-*:*:*) - echo mips-sni-sysv4 - exit 0 ;; - *:SINIX-*:*:*) - if uname -p 2>/dev/null >/dev/null ; then - UNAME_MACHINE=`(uname -p) 2>/dev/null` - echo ${UNAME_MACHINE}-sni-sysv4 - else - echo ns32k-sni-sysv - fi - exit 0 ;; -esac - -#echo '(No uname command or uname output not recognized.)' 1>&2 -#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 - -cat >dummy.c <<EOF -main () -{ -#if defined (sony) -#if defined (MIPSEB) - /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, - I don't know.... */ - printf ("mips-sony-bsd\n"); exit (0); -#else -#include <sys/param.h> - printf ("m68k-sony-newsos%s\n", -#ifdef NEWSOS4 - "4" -#else - "" -#endif - ); exit (0); -#endif -#endif - -#if defined (__arm) && defined (__acorn) && defined (__unix) - printf ("arm-acorn-riscix"); exit (0); -#endif - -#if defined (hp300) && !defined (hpux) - printf ("m68k-hp-bsd\n"); exit (0); -#endif - -#if defined (NeXT) -#if !defined (__ARCHITECTURE__) -#define __ARCHITECTURE__ "m68k" -#endif - int version; - version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; - printf ("%s-next-nextstep%s\n", __ARCHITECTURE__, version==2 ? "2" : "3"); - exit (0); -#endif - -#if defined (MULTIMAX) || defined (n16) -#if defined (UMAXV) - printf ("ns32k-encore-sysv\n"); exit (0); -#else -#if defined (CMU) - printf ("ns32k-encore-mach\n"); exit (0); -#else - printf ("ns32k-encore-bsd\n"); exit (0); -#endif -#endif -#endif - -#if defined (__386BSD__) - printf ("i386-unknown-bsd\n"); exit (0); -#endif - -#if defined (sequent) -#if defined (i386) - printf ("i386-sequent-dynix\n"); exit (0); -#endif -#if defined (ns32000) - printf ("ns32k-sequent-dynix\n"); exit (0); -#endif -#endif - -#if defined (_SEQUENT_) - printf ("i386-sequent-ptx\n"); exit (0); -#endif - -#if defined (vax) -#if !defined (ultrix) - printf ("vax-dec-bsd\n"); exit (0); -#else - printf ("vax-dec-ultrix\n"); exit (0); -#endif -#endif - -#if defined (alliant) && defined (i860) - printf ("i860-alliant-bsd\n"); exit (0); -#endif - - exit (1); -} -EOF - -${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy && rm dummy.c dummy && exit 0 -rm -f dummy.c dummy - -# Apollos put the system type in the environment. - -test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; } - -# Convex versions that predate uname can use getsysinfo(1) - -if [ -x /usr/convex/getsysinfo ] -then - case `getsysinfo -f cpu_type` in - c1*) - echo c1-convex-bsd - exit 0 ;; - c2*) - if getsysinfo -f scalar_acc - then echo c32-convex-bsd - else echo c2-convex-bsd - fi - exit 0 ;; - c34*) - echo c34-convex-bsd - exit 0 ;; - c38*) - echo c38-convex-bsd - exit 0 ;; - c4*) - echo c4-convex-bsd - exit 0 ;; - esac -fi - -#echo '(Unable to guess system type)' 1>&2 - -exit 1 diff --git a/config.sub b/config.sub deleted file mode 100755 index 5641cc1ce..000000000 --- a/config.sub +++ /dev/null @@ -1,833 +0,0 @@ -#! /bin/sh -# Configuration validation subroutine script, version 1.1. -# Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. -# This file is (in principle) common to ALL GNU software. -# The presence of a machine in this file suggests that SOME GNU software -# can handle that machine. It does not imply ALL GNU software can. -# -# This file is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -# As a special exception to the GNU General Public License, if you -# distribute this file as part of a program that contains a -# configuration script generated by Autoconf, you may include it under -# the same distribution terms that you use for the rest of that program. - -# Configuration subroutine to validate and canonicalize a configuration type. -# Supply the specified configuration type as an argument. -# If it is invalid, we print an error message on stderr and exit with code 1. -# Otherwise, we print the canonical config type on stdout and succeed. - -# This file is supposed to be the same for all GNU packages -# and recognize all the CPU types, system types and aliases -# that are meaningful with *any* GNU software. -# Each package is responsible for reporting which valid configurations -# it does not support. The user should be able to distinguish -# a failure to support a valid configuration from a meaningless -# configuration. - -# The goal of this file is to map all the various variations of a given -# machine specification into a single specification in the form: -# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM -# It is wrong to echo any other type of specification. - -if [ x$1 = x ] -then - echo Configuration name missing. 1>&2 - echo "Usage: $0 CPU-MFR-OPSYS" 1>&2 - echo "or $0 ALIAS" 1>&2 - echo where ALIAS is a recognized configuration type. 1>&2 - exit 1 -fi - -# First pass through any local machine types. -case $1 in - *local*) - echo $1 - exit 0 - ;; - *) - ;; -esac - -# Separate what the user gave into CPU-COMPANY and OS (if any). -basic_machine=`echo $1 | sed 's/-[^-]*$//'` -if [ $basic_machine != $1 ] -then os=`echo $1 | sed 's/.*-/-/'` -else os=; fi - -### Let's recognize common machines as not being operating systems so -### that things like config.sub decstation-3100 work. We also -### recognize some manufacturers as not being operating systems, so we -### can provide default operating systems below. -case $os in - -sun*os*) - # Prevent following clause from handling this invalid input. - ;; - -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ - -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ - -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ - -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ - -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ - -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp ) - os= - basic_machine=$1 - ;; - -hiux*) - os=-hiuxwe2 - ;; - -sco4) - os=-sco3.2v4 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -sco3.2.[4-9]*) - os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -sco3.2v[4-9]*) - # Don't forget version if it is 3.2v4 or newer. - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -sco*) - os=-sco3.2v2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -isc) - os=-isc2.2 - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -clix*) - basic_machine=clipper-intergraph - ;; - -isc*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'` - ;; - -lynx*) - os=-lynxos - ;; - -ptx*) - basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` - ;; - -windowsnt*) - os=`echo $os | sed -e 's/windowsnt/winnt/'` - ;; -esac - -# Decode aliases for certain CPU-COMPANY combinations. -case $basic_machine in - # Recognize the basic CPU types without company name. - # Some are omitted here because they have special meanings below. - tahoe | i[345]86 | i860 | m68k | m68000 | m88k | ns32k | arm | pyramid \ - | tron | a29k | 580 | i960 | h8300 | hppa1.0 | hppa1.1 \ - | alpha | we32k | ns16k | clipper | sparclite | i370 | sh \ - | powerpc | sparc64 | 1750a | dsp16xx | mips64 | mipsel \ - | pdp11 | mips64el | mips64orion | mips64orionel \ - | sparc) - basic_machine=$basic_machine-unknown - ;; - # Object if more than one company name word. - *-*-*) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; - # Recognize the basic CPU types with company name. - vax-* | tahoe-* | i[345]86-* | i860-* | m68k-* | m68000-* | m88k-* \ - | sparc-* | ns32k-* | fx80-* | arm-* | c[123]* \ - | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \ - | none-* | 580-* | cray2-* | h8300-* | i960-* | xmp-* | ymp-* \ - | hppa1.0-* | hppa1.1-* | alpha-* | we32k-* | cydra-* | ns16k-* \ - | pn-* | np1-* | xps100-* | clipper-* | orion-* | sparclite-* \ - | pdp11-* | sh-* | powerpc-* | sparc64-* | mips64-* | mipsel-* \ - | mips64el-* | mips64orion-* | mips64orionel-*) - ;; - # Recognize the various machine names and aliases which stand - # for a CPU type and a company and sometimes even an OS. - 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) - basic_machine=m68000-att - ;; - 3b*) - basic_machine=we32k-att - ;; - alliant | fx80) - basic_machine=fx80-alliant - ;; - altos | altos3068) - basic_machine=m68k-altos - ;; - am29k) - basic_machine=a29k-none - os=-bsd - ;; - amdahl) - basic_machine=580-amdahl - os=-sysv - ;; - amiga | amiga-*) - basic_machine=m68k-cbm - ;; - amigados) - basic_machine=m68k-cbm - os=-amigados - ;; - amigaunix | amix) - basic_machine=m68k-cbm - os=-sysv4 - ;; - apollo68) - basic_machine=m68k-apollo - os=-sysv - ;; - balance) - basic_machine=ns32k-sequent - os=-dynix - ;; - convex-c1) - basic_machine=c1-convex - os=-bsd - ;; - convex-c2) - basic_machine=c2-convex - os=-bsd - ;; - convex-c32) - basic_machine=c32-convex - os=-bsd - ;; - convex-c34) - basic_machine=c34-convex - os=-bsd - ;; - convex-c38) - basic_machine=c38-convex - os=-bsd - ;; - cray | ymp) - basic_machine=ymp-cray - os=-unicos - ;; - cray2) - basic_machine=cray2-cray - os=-unicos - ;; - crds | unos) - basic_machine=m68k-crds - ;; - da30 | da30-*) - basic_machine=m68k-da30 - ;; - decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) - basic_machine=mips-dec - ;; - delta | 3300 | motorola-3300 | motorola-delta \ - | 3300-motorola | delta-motorola) - basic_machine=m68k-motorola - ;; - delta88) - basic_machine=m88k-motorola - os=-sysv3 - ;; - dpx20 | dpx20-*) - basic_machine=rs6000-bull - os=-bosx - ;; - dpx2* | dpx2*-bull) - basic_machine=m68k-bull - os=-sysv3 - ;; - ebmon29k) - basic_machine=a29k-amd - os=-ebmon - ;; - elxsi) - basic_machine=elxsi-elxsi - os=-bsd - ;; - encore | umax | mmax) - basic_machine=ns32k-encore - ;; - fx2800) - basic_machine=i860-alliant - ;; - genix) - basic_machine=ns32k-ns - ;; - gmicro) - basic_machine=tron-gmicro - os=-sysv - ;; - h3050r* | hiux*) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - h8300hms) - basic_machine=h8300-hitachi - os=-hms - ;; - harris) - basic_machine=m88k-harris - os=-sysv3 - ;; - hp300-*) - basic_machine=m68k-hp - ;; - hp300bsd) - basic_machine=m68k-hp - os=-bsd - ;; - hp300hpux) - basic_machine=m68k-hp - os=-hpux - ;; - hp9k2[0-9][0-9] | hp9k31[0-9]) - basic_machine=m68000-hp - ;; - hp9k3[2-9][0-9]) - basic_machine=m68k-hp - ;; - hp9k7[0-9][0-9] | hp7[0-9][0-9] | hp9k8[0-9]7 | hp8[0-9]7) - basic_machine=hppa1.1-hp - ;; - hp9k8[0-9][0-9] | hp8[0-9][0-9]) - basic_machine=hppa1.0-hp - ;; - i370-ibm* | ibm*) - basic_machine=i370-ibm - os=-mvs - ;; -# I'm not sure what "Sysv32" means. Should this be sysv3.2? - i[345]86v32) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` - os=-sysv32 - ;; - i[345]86v4*) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` - os=-sysv4 - ;; - i[345]86v) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` - os=-sysv - ;; - i[345]86sol2) - basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'` - os=-solaris2 - ;; - iris | iris4d) - basic_machine=mips-sgi - case $os in - -irix*) - ;; - *) - os=-irix4 - ;; - esac - ;; - isi68 | isi) - basic_machine=m68k-isi - os=-sysv - ;; - m88k-omron*) - basic_machine=m88k-omron - ;; - magnum | m3230) - basic_machine=mips-mips - os=-sysv - ;; - merlin) - basic_machine=ns32k-utek - os=-sysv - ;; - miniframe) - basic_machine=m68000-convergent - ;; - mips3*-*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` - ;; - mips3*) - basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown - ;; - ncr3000) - basic_machine=i486-ncr - os=-sysv4 - ;; - news | news700 | news800 | news900) - basic_machine=m68k-sony - os=-newsos - ;; - news1000) - basic_machine=m68030-sony - os=-newsos - ;; - news-3600 | risc-news) - basic_machine=mips-sony - os=-newsos - ;; - next | m*-next ) - basic_machine=m68k-next - case $os in - -nextstep* ) - ;; - -ns2*) - os=-nextstep2 - ;; - *) - os=-nextstep3 - ;; - esac - ;; - nh3000) - basic_machine=m68k-harris - os=-cxux - ;; - nh[45]000) - basic_machine=m88k-harris - os=-cxux - ;; - nindy960) - basic_machine=i960-intel - os=-nindy - ;; - np1) - basic_machine=np1-gould - ;; - pa-hitachi) - basic_machine=hppa1.1-hitachi - os=-hiuxwe2 - ;; - paragon) - basic_machine=i860-intel - os=-osf - ;; - pbd) - basic_machine=sparc-tti - ;; - pbb) - basic_machine=m68k-tti - ;; - pc532 | pc532-*) - basic_machine=ns32k-pc532 - ;; - pentium-*) - # We will change tis to say i586 once there has been - # time for various packages to start to recognize that. - basic_machine=i486-`echo $basic_machine | sed 's/^[^-]*-//'` - ;; - pn) - basic_machine=pn-gould - ;; - ps2) - basic_machine=i386-ibm - ;; - rm[46]00) - basic_machine=mips-siemens - ;; - rtpc | rtpc-*) - basic_machine=romp-ibm - ;; - sequent) - basic_machine=i386-sequent - ;; - sh) - basic_machine=sh-hitachi - os=-hms - ;; - sps7) - basic_machine=m68k-bull - os=-sysv2 - ;; - spur) - basic_machine=spur-unknown - ;; - sun2) - basic_machine=m68000-sun - ;; - sun2os3) - basic_machine=m68000-sun - os=-sunos3 - ;; - sun2os4) - basic_machine=m68000-sun - os=-sunos4 - ;; - sun3os3) - basic_machine=m68k-sun - os=-sunos3 - ;; - sun3os4) - basic_machine=m68k-sun - os=-sunos4 - ;; - sun4os3) - basic_machine=sparc-sun - os=-sunos3 - ;; - sun4os4) - basic_machine=sparc-sun - os=-sunos4 - ;; - sun4sol2) - basic_machine=sparc-sun - os=-solaris2 - ;; - sun3 | sun3-*) - basic_machine=m68k-sun - ;; - sun4) - basic_machine=sparc-sun - ;; - sun386 | sun386i | roadrunner) - basic_machine=i386-sun - ;; - symmetry) - basic_machine=i386-sequent - os=-dynix - ;; - tower | tower-32) - basic_machine=m68k-ncr - ;; - udi29k) - basic_machine=a29k-amd - os=-udi - ;; - ultra3) - basic_machine=a29k-nyu - os=-sym1 - ;; - vaxv) - basic_machine=vax-dec - os=-sysv - ;; - vms) - basic_machine=vax-dec - os=-vms - ;; - vxworks960) - basic_machine=i960-wrs - os=-vxworks - ;; - vxworks68) - basic_machine=m68k-wrs - os=-vxworks - ;; - xmp) - basic_machine=xmp-cray - os=-unicos - ;; - xps | xps100) - basic_machine=xps100-honeywell - ;; - none) - basic_machine=none-none - os=-none - ;; - -# Here we handle the default manufacturer of certain CPU types. It is in -# some cases the only manufacturer, in others, it is the most popular. - mips) - basic_machine=mips-mips - ;; - romp) - basic_machine=romp-ibm - ;; - rs6000) - basic_machine=rs6000-ibm - ;; - vax) - basic_machine=vax-dec - ;; - pdp11) - basic_machine=pdp11-dec - ;; - we32k) - basic_machine=we32k-att - ;; - sparc) - basic_machine=sparc-sun - ;; - cydra) - basic_machine=cydra-cydrome - ;; - orion) - basic_machine=orion-highlevel - ;; - orion105) - basic_machine=clipper-highlevel - ;; - *) - echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 - exit 1 - ;; -esac - -# Here we canonicalize certain aliases for manufacturers. -case $basic_machine in - *-digital*) - basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` - ;; - *-commodore*) - basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` - ;; - *) - ;; -esac - -# Decode manufacturer-specific aliases for certain operating systems. - -if [ x"$os" != x"" ] -then -case $os in - # -solaris* is a basic system type, with this one exception. - -solaris1 | -solaris1.*) - os=`echo $os | sed -e 's|solaris1|sunos4|'` - ;; - -solaris) - os=-solaris2 - ;; - -unixware* | svr4*) - os=-sysv4 - ;; - -gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux|'` - ;; - # First accept the basic system types. - # The portable systems comes first. - # Each alternative must end in a *, to match a version number. - # -sysv* is not here because it comes later, after sysvr4. - -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ - | -vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[345]* \ - | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ - | -amigados* | -msdos* | -newsos* | -unicos* | -aos* \ - | -nindy* | -vxworks* | -ebmon* | -hms* | -mvs* | -clix* \ - | -riscos* | -linux* | -uniplus* | -iris* | -rtu* | -xenix* \ - | -hiux* | -386bsd* | -netbsd* | -freebsd* | -riscix* \ - | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* \ - | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta | -udi | -eabi) - ;; - -sunos5*) - os=`echo $os | sed -e 's|sunos5|solaris2|'` - ;; - -sunos6*) - os=`echo $os | sed -e 's|sunos6|solaris3|'` - ;; - -osfrose*) - os=-osfrose - ;; - -osf*) - os=-osf - ;; - -utek*) - os=-bsd - ;; - -dynix*) - os=-bsd - ;; - -acis*) - os=-aos - ;; - -ctix* | -uts*) - os=-sysv - ;; - # Preserve the version number of sinix5. - -sinix5.*) - os=`echo $os | sed -e 's|sinix|sysv|'` - ;; - -sinix*) - os=-sysv4 - ;; - -triton*) - os=-sysv3 - ;; - -oss*) - os=-sysv3 - ;; - -svr4) - os=-sysv4 - ;; - -svr3) - os=-sysv3 - ;; - -sysvr4) - os=-sysv4 - ;; - # This must come after -sysvr4. - -sysv*) - ;; - -xenix) - os=-xenix - ;; - -none) - ;; - *) - # Get rid of the `-' at the beginning of $os. - os=`echo $os | sed 's/[^-]*-//'` - echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 - exit 1 - ;; -esac -else - -# Here we handle the default operating systems that come with various machines. -# The value should be what the vendor currently ships out the door with their -# machine or put another way, the most popular os provided with the machine. - -# Note that if you're going to try to match "-MANUFACTURER" here (say, -# "-sun"), then you have to tell the case statement up towards the top -# that MANUFACTURER isn't an operating system. Otherwise, code above -# will signal an error saying that MANUFACTURER isn't an operating -# system, and we'll never get to this point. - -case $basic_machine in - *-acorn) - os=-riscix1.2 - ;; - pdp11-*) - os=-none - ;; - *-dec | vax-*) - os=-ultrix4.2 - ;; - m68*-apollo) - os=-domain - ;; - i386-sun) - os=-sunos4.0.2 - ;; - m68000-sun) - os=-sunos3 - # This also exists in the configure program, but was not the - # default. - # os=-sunos4 - ;; - *-tti) # must be before sparc entry or we get the wrong os. - os=-sysv3 - ;; - sparc-* | *-sun) - os=-sunos4.1.1 - ;; - *-ibm) - os=-aix - ;; - *-hp) - os=-hpux - ;; - *-hitachi) - os=-hiux - ;; - i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) - os=-sysv - ;; - *-cbm) - os=-amigados - ;; - *-dg) - os=-dgux - ;; - *-dolphin) - os=-sysv3 - ;; - m68k-ccur) - os=-rtu - ;; - m88k-omron*) - os=-luna - ;; - *-sequent) - os=-ptx - ;; - *-crds) - os=-unos - ;; - *-ns) - os=-genix - ;; - i370-*) - os=-mvs - ;; - *-next) - os=-nextstep3 - ;; - *-gould) - os=-sysv - ;; - *-highlevel) - os=-bsd - ;; - *-encore) - os=-bsd - ;; - *-sgi) - os=-irix - ;; - *-siemens) - os=-sysv4 - ;; - *-masscomp) - os=-rtu - ;; - *) - os=-none - ;; -esac -fi - -# Here we handle the case where we know the os, and the CPU type, but not the -# manufacturer. We pick the logical manufacturer. -vendor=unknown -case $basic_machine in - *-unknown) - case $os in - -riscix*) - vendor=acorn - ;; - -sunos*) - vendor=sun - ;; - -lynxos*) - vendor=lynx - ;; - -aix*) - vendor=ibm - ;; - -hpux*) - vendor=hp - ;; - -hiux*) - vendor=hitachi - ;; - -unos*) - vendor=crds - ;; - -dgux*) - vendor=dg - ;; - -luna*) - vendor=omron - ;; - -genix*) - vendor=ns - ;; - -mvs*) - vendor=ibm - ;; - -ptx*) - vendor=sequent - ;; - -vxworks*) - vendor=wrs - ;; - esac - basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` - ;; -esac - -echo $basic_machine$os diff --git a/configure b/configure deleted file mode 100755 index 1ea1e2b24..000000000 --- a/configure +++ /dev/null @@ -1,1059 +0,0 @@ -#! /bin/sh - -# Guess values for system-dependent variables and create Makefiles. -# Generated automatically using autoconf version 2.12 -# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - -# Defaults: -ac_help= -ac_default_prefix=/usr/local -# Any additions from configure.in: - -# Initialize some variables set by options. -# The variables have the same names as the options, with -# dashes changed to underlines. -build=NONE -cache_file=./config.cache -exec_prefix=NONE -host=NONE -no_create= -nonopt=NONE -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -target=NONE -verbose= -x_includes=NONE -x_libraries=NONE -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datadir='${prefix}/share' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -libdir='${exec_prefix}/lib' -includedir='${prefix}/include' -oldincludedir='/usr/include' -infodir='${prefix}/info' -mandir='${prefix}/man' - -# Initialize some other variables. -subdirs= -MFLAGS= MAKEFLAGS= -# Maximum number of lines to put in a shell here document. -ac_max_here_lines=12 - -ac_prev= -for ac_option -do - - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval "$ac_prev=\$ac_option" - ac_prev= - continue - fi - - case "$ac_option" in - -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; - *) ac_optarg= ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case "$ac_option" in - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir="$ac_optarg" ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build="$ac_optarg" ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file="$ac_optarg" ;; - - -datadir | --datadir | --datadi | --datad | --data | --dat | --da) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ - | --da=*) - datadir="$ac_optarg" ;; - - -disable-* | --disable-*) - ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - eval "enable_${ac_feature}=no" ;; - - -enable-* | --enable-*) - ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "enable_${ac_feature}='$ac_optarg'" ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix="$ac_optarg" ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he) - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat << EOF -Usage: configure [options] [host] -Options: [defaults in brackets after descriptions] -Configuration: - --cache-file=FILE cache test results in FILE - --help print this message - --no-create do not create output files - --quiet, --silent do not print \`checking...' messages - --version print the version of autoconf that created configure -Directory and file names: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [same as prefix] - --bindir=DIR user executables in DIR [EPREFIX/bin] - --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] - --libexecdir=DIR program executables in DIR [EPREFIX/libexec] - --datadir=DIR read-only architecture-independent data in DIR - [PREFIX/share] - --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data in DIR - [PREFIX/com] - --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] - --libdir=DIR object code libraries in DIR [EPREFIX/lib] - --includedir=DIR C header files in DIR [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] - --infodir=DIR info documentation in DIR [PREFIX/info] - --mandir=DIR man documentation in DIR [PREFIX/man] - --srcdir=DIR find the sources in DIR [configure dir or ..] - --program-prefix=PREFIX prepend PREFIX to installed program names - --program-suffix=SUFFIX append SUFFIX to installed program names - --program-transform-name=PROGRAM - run sed PROGRAM on installed program names -EOF - cat << EOF -Host type: - --build=BUILD configure for building on BUILD [BUILD=HOST] - --host=HOST configure for HOST [guessed] - --target=TARGET configure for TARGET [TARGET=HOST] -Features and packages: - --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) - --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --x-includes=DIR X include files are in DIR - --x-libraries=DIR X library files are in DIR -EOF - if test -n "$ac_help"; then - echo "--enable and --with options recognized:$ac_help" - fi - exit 0 ;; - - -host | --host | --hos | --ho) - ac_prev=host ;; - -host=* | --host=* | --hos=* | --ho=*) - host="$ac_optarg" ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir="$ac_optarg" ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir="$ac_optarg" ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir="$ac_optarg" ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir="$ac_optarg" ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst \ - | --locals | --local | --loca | --loc | --lo) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* \ - | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) - localstatedir="$ac_optarg" ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir="$ac_optarg" ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir="$ac_optarg" ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix="$ac_optarg" ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix="$ac_optarg" ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix="$ac_optarg" ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name="$ac_optarg" ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir="$ac_optarg" ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir="$ac_optarg" ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site="$ac_optarg" ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir="$ac_optarg" ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir="$ac_optarg" ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target="$ac_optarg" ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers) - echo "configure generated by autoconf version 2.12" - exit 0 ;; - - -with-* | --with-*) - ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "with_${ac_package}='$ac_optarg'" ;; - - -without-* | --without-*) - ac_package=`echo $ac_option|sed -e 's/-*without-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - eval "with_${ac_package}=no" ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes="$ac_optarg" ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries="$ac_optarg" ;; - - -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } - ;; - - *) - if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then - echo "configure: warning: $ac_option: invalid host type" 1>&2 - fi - if test "x$nonopt" != xNONE; then - { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } - fi - nonopt="$ac_option" - ;; - - esac -done - -if test -n "$ac_prev"; then - { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } -fi - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -# File descriptor usage: -# 0 standard input -# 1 file creation -# 2 errors and warnings -# 3 some systems may open it to /dev/tty -# 4 used on the Kubota Titan -# 6 checking for... messages and results -# 5 compiler messages saved in config.log -if test "$silent" = yes; then - exec 6>/dev/null -else - exec 6>&1 -fi -exec 5>./config.log - -echo "\ -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. -" 1>&5 - -# Strip out --no-create and --no-recursion so they do not pile up. -# Also quote any args containing shell metacharacters. -ac_configure_args= -for ac_arg -do - case "$ac_arg" in - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) ;; - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; - *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) - ac_configure_args="$ac_configure_args '$ac_arg'" ;; - *) ac_configure_args="$ac_configure_args $ac_arg" ;; - esac -done - -# NLS nuisances. -# Only set these to C if already set. These must not be set unconditionally -# because not all systems understand e.g. LANG=C (notably SCO). -# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! -# Non-C LC_CTYPE values break the ctype check. -if test "${LANG+set}" = set; then LANG=C; export LANG; fi -if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi -if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi -if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -rf conftest* confdefs.h -# AIX cpp loses on an empty file, so make sure it contains at least a newline. -echo > confdefs.h - -# A filename unique to this package, relative to the directory that -# configure is in, which we can look for to find out if srcdir is correct. -ac_unique_file=Makefile.in - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then its parent. - ac_prog=$0 - ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` - test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. - srcdir=$ac_confdir - if test ! -r $srcdir/$ac_unique_file; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r $srcdir/$ac_unique_file; then - if test "$ac_srcdir_defaulted" = yes; then - { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } - else - { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } - fi -fi -srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` - -# Prefer explicitly selected file to automatically selected ones. -if test -z "$CONFIG_SITE"; then - if test "x$prefix" != xNONE; then - CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" - else - CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" - fi -fi -for ac_site_file in $CONFIG_SITE; do - if test -r "$ac_site_file"; then - echo "loading site script $ac_site_file" - . "$ac_site_file" - fi -done - -if test -r "$cache_file"; then - echo "loading cache $cache_file" - . $cache_file -else - echo "creating cache $cache_file" - > $cache_file -fi - -ac_ext=c -# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. -ac_cpp='$CPP $CPPFLAGS' -ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' -ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' -cross_compiling=$ac_cv_prog_cc_cross - -if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then - # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. - if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then - ac_n= ac_c=' -' ac_t=' ' - else - ac_n=-n ac_c= ac_t= - fi -else - ac_n= ac_c='\c' ac_t= -fi - - -. $srcdir/GUILE-VERSION -ac_aux_dir= -for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do - if test -f $ac_dir/install-sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f $ac_dir/install.sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - fi -done -if test -z "$ac_aux_dir"; then - { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } -fi -ac_config_guess=$ac_aux_dir/config.guess -ac_config_sub=$ac_aux_dir/config.sub -ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. - -# Find a good install program. We prefer a C program (faster), -# so one script is as good as another. But avoid the broken or -# incompatible versions: -# SysV /etc/install, /usr/sbin/install -# SunOS /usr/etc/install -# IRIX /sbin/install -# AIX /bin/install -# AFS /usr/afsws/bin/install, which mishandles nonexistent args -# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" -# ./install, which can be erroneously created by make from ./install.sh. -echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:553: checking for a BSD compatible install" >&5 -if test -z "$INSTALL"; then -if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - # Account for people who put trailing slashes in PATH elements. - case "$ac_dir/" in - /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; - *) - # OSF1 and SCO ODT 3.0 have their own names for install. - for ac_prog in ginstall installbsd scoinst install; do - if test -f $ac_dir/$ac_prog; then - if test $ac_prog = install && - grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then - # AIX install. It has an incompatible calling convention. - # OSF/1 installbsd also uses dspmsg, but is usable. - : - else - ac_cv_path_install="$ac_dir/$ac_prog -c" - break 2 - fi - fi - done - ;; - esac - done - IFS="$ac_save_IFS" - -fi - if test "${ac_cv_path_install+set}" = set; then - INSTALL="$ac_cv_path_install" - else - # As a last resort, use the slow shell script. We don't cache a - # path for INSTALL within a source directory, because that will - # break other packages using the cache if that directory is - # removed, or if the path is relative. - INSTALL="$ac_install_sh" - fi -fi -echo "$ac_t""$INSTALL" 1>&6 - -# Use test -z because SunOS4 sh mishandles braces in ${var-val}. -# It thinks the first close brace ends the variable substitution. -test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' - -test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' - - -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' - - -PACKAGE=$PACKAGE - -cat >> confdefs.h <<EOF -#define PACKAGE "$PACKAGE" -EOF - -VERSION=$VERSION - -cat >> confdefs.h <<EOF -#define VERSION "$VERSION" -EOF - -echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6 -echo "configure:619: checking whether build environment is sane" >&5 -echo timestamp > conftestfile -# Do this in a subshell so we don't clobber the current shell's -# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? -if (set X `ls -t $srcdir/configure conftestfile`; test "$2" = conftestfile) -then - # Ok. - : -else - { echo "configure: error: newly created file is older than distributed files! -Check your system clock" 1>&2; exit 1; } -fi -rm -f conftest* -echo "$ac_t""yes" 1>&6 -if test "$program_transform_name" = s,x,x,; then - program_transform_name= -else - # Double any \ or $. echo might interpret backslashes. - cat <<\EOF_SED > conftestsed -s,\\,\\\\,g; s,\$,$$,g -EOF_SED - program_transform_name="`echo $program_transform_name|sed -f conftestsed`" - rm -f conftestsed -fi -test "$program_prefix" != NONE && - program_transform_name="s,^,${program_prefix},; $program_transform_name" -# Use a double $ so make ignores it. -test "$program_suffix" != NONE && - program_transform_name="s,\$\$,${program_suffix},; $program_transform_name" - -# sed with no file args requires a program. -test "$program_transform_name" = "" && program_transform_name="s,x,x," - -echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 -echo "configure:653: checking whether ${MAKE-make} sets \${MAKE}" >&5 -set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftestmake <<\EOF -all: - @echo 'ac_maketemp="${MAKE}"' -EOF -# GNU make sometimes prints "make[1]: Entering...", which would confuse us. -eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=` -if test -n "$ac_maketemp"; then - eval ac_cv_prog_make_${ac_make}_set=yes -else - eval ac_cv_prog_make_${ac_make}_set=no -fi -rm -f conftestmake -fi -if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then - echo "$ac_t""yes" 1>&6 - SET_MAKE= -else - echo "$ac_t""no" 1>&6 - SET_MAKE="MAKE=${MAKE-make}" -fi - - -all_subdirs=`cat $srcdir/*/PLUGIN/REQ $srcdir/*/PLUGIN/OPT /dev/null | tsort | xargs echo` -req_subdirs=`cat $srcdir/*/PLUGIN/REQ /dev/null | tsort | xargs echo` -opt_subdirs=`cat $srcdir/*/PLUGIN/OPT /dev/null | tsort | xargs echo` - -subdirs="$all_subdirs" - -for d in $all_subdirs; do - if test -d $srcdir/$d ; then - existingdirs="$existingdirs $d" - test -n "$silent" || echo Configuring plug-in component $d - fi -done - -for d in $req_subdirs; do - test -d $srcdir/$d || { - echo ERROR: Missing required package: $d 1>&2 - exit 1 - } -done - - -trap '' 1 2 15 -cat > confcache <<\EOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs. It is not useful on other systems. -# If it contains results you don't want to keep, you may remove or edit it. -# -# By default, configure uses ./config.cache as the cache file, -# creating it if it does not exist already. You can give configure -# the --cache-file=FILE option to use a different cache file; that is -# what configure does when it calls configure scripts in -# subdirectories, so they share the cache. -# Giving --cache-file=/dev/null disables caching, for debugging configure. -# config.status only pays attention to the cache file if you give it the -# --recheck option to rerun configure. -# -EOF -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, don't put newlines in cache variables' values. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -(set) 2>&1 | - case `(ac_space=' '; set) 2>&1` in - *ac_space=\ *) - # `set' does not quote correctly, so add quotes (double-quote substitution - # turns \\\\ into \\, and sed turns \\ into \). - sed -n \ - -e "s/'/'\\\\''/g" \ - -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" - ;; - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' - ;; - esac >> confcache -if cmp -s $cache_file confcache; then - : -else - if test -w $cache_file; then - echo "updating cache $cache_file" - cat confcache > $cache_file - else - echo "not updating unwritable cache $cache_file" - fi -fi -rm -f confcache - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -# Any assignment to VPATH causes Sun make to only execute -# the first set of double-colon rules, so remove it if not needed. -# If there is a colon in the path, we need to keep it. -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' -fi - -trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 - -# Transform confdefs.h into DEFS. -# Protect against shell expansion while executing Makefile rules. -# Protect against Makefile macro expansion. -cat > conftest.defs <<\EOF -s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g -s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g -s%\[%\\&%g -s%\]%\\&%g -s%\$%$$%g -EOF -DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` -rm -f conftest.defs - - -# Without the "./", some shells look in PATH for config.status. -: ${CONFIG_STATUS=./config.status} - -echo creating $CONFIG_STATUS -rm -f $CONFIG_STATUS -cat > $CONFIG_STATUS <<EOF -#! /bin/sh -# Generated automatically by configure. -# Run this file to recreate the current configuration. -# This directory was configured as follows, -# on host `(hostname || uname -n) 2>/dev/null | sed 1q`: -# -# $0 $ac_configure_args -# -# Compiler output produced by configure, useful for debugging -# configure, is in ./config.log if it exists. - -ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" -for ac_option -do - case "\$ac_option" in - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" - exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; - -version | --version | --versio | --versi | --vers | --ver | --ve | --v) - echo "$CONFIG_STATUS generated by autoconf version 2.12" - exit 0 ;; - -help | --help | --hel | --he | --h) - echo "\$ac_cs_usage"; exit 0 ;; - *) echo "\$ac_cs_usage"; exit 1 ;; - esac -done - -ac_given_srcdir=$srcdir -ac_given_INSTALL="$INSTALL" - -trap 'rm -fr `echo "Makefile doc/Makefile doc/guile-programmer/Makefile doc/guile-user/Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 -EOF -cat >> $CONFIG_STATUS <<EOF - -# Protect against being on the right side of a sed subst in config.status. -sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g; - s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF -$ac_vpsub -$extrasub -s%@CFLAGS@%$CFLAGS%g -s%@CPPFLAGS@%$CPPFLAGS%g -s%@CXXFLAGS@%$CXXFLAGS%g -s%@DEFS@%$DEFS%g -s%@LDFLAGS@%$LDFLAGS%g -s%@LIBS@%$LIBS%g -s%@exec_prefix@%$exec_prefix%g -s%@prefix@%$prefix%g -s%@program_transform_name@%$program_transform_name%g -s%@bindir@%$bindir%g -s%@sbindir@%$sbindir%g -s%@libexecdir@%$libexecdir%g -s%@datadir@%$datadir%g -s%@sysconfdir@%$sysconfdir%g -s%@sharedstatedir@%$sharedstatedir%g -s%@localstatedir@%$localstatedir%g -s%@libdir@%$libdir%g -s%@includedir@%$includedir%g -s%@oldincludedir@%$oldincludedir%g -s%@infodir@%$infodir%g -s%@mandir@%$mandir%g -s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g -s%@INSTALL_DATA@%$INSTALL_DATA%g -s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g -s%@PACKAGE@%$PACKAGE%g -s%@VERSION@%$VERSION%g -s%@SET_MAKE@%$SET_MAKE%g -s%@subdirs@%$subdirs%g -s%@existingdirs@%$existingdirs%g - -CEOF -EOF - -cat >> $CONFIG_STATUS <<\EOF - -# Split the substitutions into bite-sized pieces for seds with -# small command number limits, like on Digital OSF/1 and HP-UX. -ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. -ac_file=1 # Number of current file. -ac_beg=1 # First line for current file. -ac_end=$ac_max_sed_cmds # Line after last line for current file. -ac_more_lines=: -ac_sed_cmds="" -while $ac_more_lines; do - if test $ac_beg -gt 1; then - sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file - else - sed "${ac_end}q" conftest.subs > conftest.s$ac_file - fi - if test ! -s conftest.s$ac_file; then - ac_more_lines=false - rm -f conftest.s$ac_file - else - if test -z "$ac_sed_cmds"; then - ac_sed_cmds="sed -f conftest.s$ac_file" - else - ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" - fi - ac_file=`expr $ac_file + 1` - ac_beg=$ac_end - ac_end=`expr $ac_end + $ac_max_sed_cmds` - fi -done -if test -z "$ac_sed_cmds"; then - ac_sed_cmds=cat -fi -EOF - -cat >> $CONFIG_STATUS <<EOF - -CONFIG_FILES=\${CONFIG_FILES-"Makefile doc/Makefile doc/guile-programmer/Makefile doc/guile-user/Makefile"} -EOF -cat >> $CONFIG_STATUS <<\EOF -for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case "$ac_file" in - *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` - ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; - *) ac_file_in="${ac_file}.in" ;; - esac - - # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. - - # Remove last slash and all that follows it. Not all systems have dirname. - ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` - if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then - # The file is in a subdirectory. - test ! -d "$ac_dir" && mkdir "$ac_dir" - ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" - # A "../" for each directory in $ac_dir_suffix. - ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` - else - ac_dir_suffix= ac_dots= - fi - - case "$ac_given_srcdir" in - .) srcdir=. - if test -z "$ac_dots"; then top_srcdir=. - else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; - /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; - *) # Relative path. - srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" - top_srcdir="$ac_dots$ac_given_srcdir" ;; - esac - - case "$ac_given_INSTALL" in - [/$]*) INSTALL="$ac_given_INSTALL" ;; - *) INSTALL="$ac_dots$ac_given_INSTALL" ;; - esac - - echo creating "$ac_file" - rm -f "$ac_file" - configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." - case "$ac_file" in - *Makefile*) ac_comsub="1i\\ -# $configure_input" ;; - *) ac_comsub= ;; - esac - - ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` - sed -e "$ac_comsub -s%@configure_input@%$configure_input%g -s%@srcdir@%$srcdir%g -s%@top_srcdir@%$top_srcdir%g -s%@INSTALL@%$INSTALL%g -" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file -fi; done -rm -f conftest.s* - -EOF -cat >> $CONFIG_STATUS <<EOF - -EOF -cat >> $CONFIG_STATUS <<\EOF - -exit 0 -EOF -chmod +x $CONFIG_STATUS -rm -fr confdefs* $ac_clean_files -test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 - -if test "$no_recursion" != yes; then - - # Remove --cache-file and --srcdir arguments so they do not pile up. - ac_sub_configure_args= - ac_prev= - for ac_arg in $ac_configure_args; do - if test -n "$ac_prev"; then - ac_prev= - continue - fi - case "$ac_arg" in - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - ;; - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - ;; - *) ac_sub_configure_args="$ac_sub_configure_args $ac_arg" ;; - esac - done - - for ac_config_dir in $all_subdirs; do - - # Do not complain, so a configure script can configure whichever - # parts of a large source tree are present. - if test ! -d $srcdir/$ac_config_dir; then - continue - fi - - echo configuring in $ac_config_dir - - case "$srcdir" in - .) ;; - *) - if test -d ./$ac_config_dir || mkdir ./$ac_config_dir; then :; - else - { echo "configure: error: can not create `pwd`/$ac_config_dir" 1>&2; exit 1; } - fi - ;; - esac - - ac_popdir=`pwd` - cd $ac_config_dir - - # A "../" for each directory in /$ac_config_dir. - ac_dots=`echo $ac_config_dir|sed -e 's%^\./%%' -e 's%[^/]$%&/%' -e 's%[^/]*/%../%g'` - - case "$srcdir" in - .) # No --srcdir option. We are building in place. - ac_sub_srcdir=$srcdir ;; - /*) # Absolute path. - ac_sub_srcdir=$srcdir/$ac_config_dir ;; - *) # Relative path. - ac_sub_srcdir=$ac_dots$srcdir/$ac_config_dir ;; - esac - - # Check for guested configure; otherwise get Cygnus style configure. - if test -f $ac_sub_srcdir/configure; then - ac_sub_configure=$ac_sub_srcdir/configure - elif test -f $ac_sub_srcdir/configure.in; then - ac_sub_configure=$ac_configure - else - echo "configure: warning: no configuration information is in $ac_config_dir" 1>&2 - ac_sub_configure= - fi - - # The recursion is here. - if test -n "$ac_sub_configure"; then - - # Make the cache file name correct relative to the subdirectory. - case "$cache_file" in - /*) ac_sub_cache_file=$cache_file ;; - *) # Relative path. - ac_sub_cache_file="$ac_dots$cache_file" ;; - esac - case "$ac_given_INSTALL" in - [/$]*) INSTALL="$ac_given_INSTALL" ;; - *) INSTALL="$ac_dots$ac_given_INSTALL" ;; - esac - - echo "running ${CONFIG_SHELL-/bin/sh} $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_sub_srcdir" - # The eval makes quoting arguments work. - if eval ${CONFIG_SHELL-/bin/sh} $ac_sub_configure $ac_sub_configure_args --cache-file=$ac_sub_cache_file --srcdir=$ac_sub_srcdir - then : - else - { echo "configure: error: $ac_sub_configure failed for $ac_config_dir" 1>&2; exit 1; } - fi - fi - - cd $ac_popdir - done -fi - diff --git a/configure.in b/configure.in deleted file mode 100644 index 6a0ec7973..000000000 --- a/configure.in +++ /dev/null @@ -1,27 +0,0 @@ -dnl Process this file with autoconf to produce configure. -AC_INIT(Makefile.in) -. $srcdir/GUILE-VERSION -AM_INIT_AUTOMAKE($PACKAGE, $VERSION) - -dnl FIXME: tsort, xargs not GNU standard. -all_subdirs=`cat $srcdir/*/PLUGIN/REQ $srcdir/*/PLUGIN/OPT /dev/null | tsort | xargs echo` -req_subdirs=`cat $srcdir/*/PLUGIN/REQ /dev/null | tsort | xargs echo` -opt_subdirs=`cat $srcdir/*/PLUGIN/OPT /dev/null | tsort | xargs echo` - -AC_CONFIG_SUBDIRS($all_subdirs) -for d in $all_subdirs; do - if test -d $srcdir/$d ; then - existingdirs="$existingdirs $d" - test -n "$silent" || echo Configuring plug-in component $d - fi -done - -for d in $req_subdirs; do - test -d $srcdir/$d || { - echo ERROR: Missing required package: $d 1>&2 - exit 1 - } -done - -AC_SUBST(existingdirs) -AC_OUTPUT(Makefile doc/Makefile doc/guile-programmer/Makefile doc/guile-user/Makefile) diff --git a/guile.m4 b/guile.m4 deleted file mode 100644 index 58ee47661..000000000 --- a/guile.m4 +++ /dev/null @@ -1,13 +0,0 @@ -## An m4 macro to initialize a guile module. -## Enhance as required. - -dnl Usage: AM_INIT_GUILE_MODULE(module-name) -dnl This macro will automatically get the guile version from the -dnl top-level srcdir, and will initialize automake. It also -dnl defines the `module' variable. -AC_DEFUN([AM_INIT_GUILE_MODULE],[ -. $srcdir/../GUILE-VERSION -AM_INIT_AUTOMAKE($PACKAGE, $VERSION) -AC_CONFIG_AUX_DIR(..) -module=[$1] -AC_SUBST(module)]) diff --git a/ice-9/.cvsignore b/ice-9/.cvsignore deleted file mode 100644 index 16b8c4510..000000000 --- a/ice-9/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -Makefile -config.log -config.status diff --git a/ice-9/COPYING b/ice-9/COPYING deleted file mode 100644 index 9648fb9ea..000000000 --- a/ice-9/COPYING +++ /dev/null @@ -1,339 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991, 1992, 1993 Free Software Foundation, Inc. - 675 Mass Ave, Cambridge, MA 02139, USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - Appendix: How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - <one line to give the program's name and a brief idea of what it does.> - Copyright (C) 19yy <name of author> - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) 19yy name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - <signature of Ty Coon>, 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog deleted file mode 100644 index c41e52b6f..000000000 --- a/ice-9/ChangeLog +++ /dev/null @@ -1,463 +0,0 @@ -Wed Dec 11 21:06:05 1996 Gary Houston <ghouston@actrix.gen.nz> - - * slib.scm (slib-parent-dir): throw error if #f returned from - %search-load-path. - -Sat Nov 30 23:57:28 1996 Tom Tromey <tromey@cygnus.com> - - * PLUGIN/greet, PLUGIN/split.sed, PLUGIN/this.configure: Removed. - * Makefile.am, aclocal.m4: New files. - * configure.in: Updated for Automake. - -Wed Nov 27 14:16:14 1996 Marius Vollmer <mvo@zagadka.ping.de> - - * boot-9.scm (macroexpand-1, macroexpand), slib.scm - (slib:features), r4rs.scm (%load-verbosely): "defined?" is now a - function, use it accordingly. - -Thu Nov 21 11:12:10 1996 Jim Blandy <jimb@floss.cyclic.com> - - It's an "eval closure", not an "eval thunk." A thunk is a - function of no arguments. - * boot-9.scm (module-type): Rename module field. - (make-module, eval-in-module, make-root-module, - set-current-module): Uses changed. - (module-eval-closure, set-module-eval-closure!, - root-module-closure): Renamed from module-eval-thunk, - set-module-eval-thunk!, root-module-thunk. - (set-current-module): Change uses of *top-level-lookup-thunk* to - *top-level-eval-closure*. - -Wed Nov 20 14:45:27 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * slib.scm (slib-parent-dir): Use string-length, not length. - (Thanks to Bernard Urban.) - -Sat Nov 2 20:00:42 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se> - -* * boot-9.scm: The debugging evaluator and recording of positions - aren't enabled by default any longer (they are switched on in - debug.scm). But during development we want to have them also - *inside* boot-9.scm. Therefore, two lines are added at the - beginning of boot-9.scm to enable these. - - Call `provide' so that `records' are included among the - `*features*'. - - The scheme for saving the stack has been adjusted: save-stack is - now commonly available for saving the stack. Calling `save-stack' - sets a flag `stack-saved?' which prevents overwriting the stack. - `stack-saved?' is reset at `abort'. - - Spelling correction: seperate --> separate. - - Removed `:'s that had creeped into some comments. - -* The repl now doesn't print #<unspecified> results any longer - If the user wants to see this, he can do - (assert-repl-print-unspecified #t) in his startup file. - -* The user now gets a friendly message instead of a backtrace at - error. - - Added `before-read-hook'. - - Load module (ice-9 emacs) if option `-e' was specified. - - (provide): New function. - - (error): Save stack at entry, so that Guile entrails won't show up - in backtraces. - - (backtrace): New function. - -* (save-stack): Can now take arbitrary number of stack narrowing - specifier pairs. The first specifier in a pair controls inner - border, the second the outer border. A number means cut that - number of frames, a procedure object means cut until that object - is found in operator position in a frame. - - * debug.scm: Enable debugging evaluator and recording of positions - by default. - - * slib.scm (slib:load): Adapt to the new behavior of - primitive-load: It doesn't any longer try both with and without - ".scm" extension. (We don't want to use %search-load-path here.) - - (implementation-vicinity): New function. slib requires it - - (library-vicinity): Updated. - - Load "require.scm" in the library-vicinity. - - (install-require-vicinity, install-require-module): New functions. - -Mon Oct 28 17:56:29 1996 Jim Blandy <jimb@floss.cyclic.com> - - * boot-9.scm (load-from-path): New function. - - * boot-9.scm (try-load, basic-try-load, try-load-module, - try-load): Deleted. I don't think they're being used. - - * Makefile.in (scm_files): Add r4rs.scm and test.scm to this list, - so they'll get distributed. - - Get Guile to be a little less chatty by default. The new user - should see as little clutter as possible. - * r4rs.scm (%load-verbosely): Make this #f by default. - * boot-9.scm (scm-repl-verbose): Make this #f by default. - (scm-style-repl): Don't run 'pk' on the value passed to quit. - - * r4rs.scm: New file. - * boot-9.scm: Load r4rs.scm, first thing. - (OPEN_READ, OPEN_WRITE, OPEN_BOTH, *null-device*, open-input-file, - open-output-file, open-io-file, close-input-port, - close-output-port, close-io-port, call-with-input-file, - call-with-output-file, with-input-from-port, with-output-to-port, - with-error-to-port, with-input-from-file, with-output-to-file, - with-error-to-file, with-input-from-string, with-output-to-string, - with-error-to-string, the-eof-object): Definitions moved to - r4rs.scm. Not all of them are R4RS, but those that are use those - that are not. - (load, %load-verbosely, %load-announce): Moved, along with code to - set %load-hook, to r4rs.scm. - - * test.scm: New file. - - * boot-9.scm (integer?): Definition deleted, in favor of the one - present in libguile (which used to be called int?). I have no - idea why integer? didn't just call int? to begin with. - - * boot-9.scm (<, <=, =, >, >=): Definitions in terms of <?, <=?, - =?, >?, and >=? deleted; they're defined that way by libguile now. - - * boot-9.scm (load): Simplified; primitive-load does most of this - work now. - (%load-announce-win): Removed; no longer used. Set %load-hook to - call %load-announce. - -Sun Oct 27 07:47:03 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm (stat:dev, stat:ino, stat:mode, stat:nlink, stat:uid, - stat:gid, stat:rdev, stat:size, stat:atime, stat:mtime, - stat:ctime, stat:blksize, stat:blocks) accessor functions for stat - components. - (file-is-directory?): use stat:type. - -Fri Oct 25 03:34:47 1996 Jim Blandy <jimb@floss.cyclic.com> - - * boot-9.scm (%read-sharp): Don't recognize the `#!' syntax here; - that's now taken care of in libguile, and in a way compatible with - SCSH (which this isn't). - -Mon Oct 21 18:52:36 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * boot-9.scm: Formatting tweaks. - -Fri Oct 18 01:03:08 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se> - - * boot-9.scm (handle-system-error): Added hooks before-error-hook, - after-error-hook, before-backtrace-hook and after-backtrace-hook - to the error handler. E.g.: fancy emacs support could plug into - these. - (save-stack): New function. The stack is now made differently - depending on the stack id. (The motivation is to make a better - choice regarding what stack frames to present to the user.) - (error-catching-loop): Stack handling code moved outside into - save-stack. - -Thu Oct 17 20:33:08 1996 Gary Houston <ghouston@actrix.gen.nz> - - * Makefile.in (scm_files): add expect.scm. - - * expect.scm: new file ported from guile-iii. - - * boot-9.scm: remove handle-system-error, after moving the code into - error-catching-loop. - Don't set 'throw-handler-default property on error keys. - Just interpret (almost) any throw with 4 args as an error throw. - Delete some try-load stuff that was already commented out. - - Second thoughts, keep handle-system-error but call it from - error-catching-loop. - -Tue Oct 15 17:07:20 1996 Jim Blandy <jimb@floss.cyclic.com> - - * boot-9.scm: Doc fixes. - (make-module): Rework for readability. - (make-root-module, make-scm-module): USES argument to make-module - should be '(), not #f. - - * boot-9.scm (try-load): %sys-load-path has been renamed to - primitive-load-path; adjust call here. - -Tue Oct 15 14:25:01 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> - - * boot-9.scm (signal-handler): Bugfix: Moved the recording of - the stack to the correct place: when it is decided to generate an - error-signal. - -Mon Oct 14 22:20:30 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> - - * boot-9.scm (error-catching-loop, signal-handler, - handle-system-error): Backtracing now works for signals aswell; - Backtracing mechanism can now identify the stack root created by - start-stack so that the user isn't exposed to system stack frames. - -Mon Oct 14 06:05:42 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> - - * Makefile.in: Added threads.scm. - -Mon Oct 14 04:21:51 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> - - * debug.scm (make-enable, make-disable): Simplified. - - * boot-9.scm: Renamed %%throw-handler-default --> - throw-handler-default. - ((handle-system-error key . arg-list)): Changed the way errors are - reported. - ((scm-style-repl)): Wrap up the call to eval in a start-stack - acro. - ((error-catching-loop thunk)): Introduce a lazy-catch into - error-catching-loop so that the stack can be captured. - -Thu Oct 10 22:27:32 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * mapping.scm (hash-table-mapping): Explicitly request that - make-vector fill new vectors with '(); this will make it easier to - port Guile Scheme code to other Schemes. - * boot-9.scm (make-print-style, make-print-table): Same. - -Sun Oct 6 03:54:59 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm (load): rewritten again. - Append "." to the default %load-path. - (feature?): new function: checks for a symbol in the features list. - (module-local-variable): remove apparently useless (caddr (list m v - ...)) - (%load-announce): minor formatting change. - (file-exists?): use access? if posix is featured. - (file-is-directory?): use stat if i/o-extensions is featured. - (try-module-autoload module-name): use file-exists? before - file-is-directory? - -Sat Oct 5 18:54:03 1996 Mikael Djurfeldt <mdj@kenneth> - - * boot-9.scm: Added conditional loading of threads.scm. - - * threads.scm: New file. Modified from the Cygnus-r0.3 - distribution. - - * boot-9.scm (error-catching-loop): Added handling of key - `switch-repl'. - - * boot-9.scm: Name change %%bad-throw --> bad-throw. - -Wed Oct 2 23:38:44 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * boot-9.scm (make-record-type, record-constructor): Don't assume - the empty list is false when parsing the argument list. - -Mon Sep 30 22:15:50 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * boot-9.scm (signal-handler): Clean up logic. - - * boot-9.scm (load): Assume %load-path is always bound. - -Sat Sep 28 00:15:37 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm (error): replace another throw with scm-error. Throw - to 'misc-error instead of 'error (no need to distinguish these.) - Don't set up 'error as a key. - Set up regex-error as a key, if regex is available. - (signal-handler): use scm-error, not throw. - -* (%try-load, try-load-with-path, %load, load-with-path, - basic-try-load-with-path, basic-load-with-path, - try-load-module-with-path,load-module-with-path): deleted, since - they seem redundant. - (try-load): define using %try-load, not try-load-with-path. -* (load): rewritten. load tries to open the file directly and - with a .scm extension before searching the library directories - (should "." be added to %load-path? then load could still open - directly files starting with "/"). - (try-module-autoload): use load, not load-with-path. - (%load-indent): deleted, -2 was causing errors. - - (%read-sharp): use port-line, not line-number. - -Fri Sep 27 16:23:51 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * boot-9.scm (%%bad-throw): Delete definition. 1) It's very - straightforward to provide the equivalent functionality using - (catch #t ...), so there's no need for the extra complexity. 2) - Outside the context of a read-eval-print loop (which Guile should - not require) it's not clear we should do anything more complicated - than print an error and exit; the user or REPL can establish - something better if it wants. 3) In that case, it's much more - robust to just do it in the C code. - -Tue Sep 24 06:53:04 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm (%try-load): define using primitive-load. Previously - %try-load itself was the primitive. - (load-with-path): use scm-error instead of %load-announce-lossage. - Errors are thrown to 'misc-error instead of 'could-not-load. - (%load-announce-lossage): deleted. - -Mon Sep 23 00:16:31 1996 Mikael Djurfeldt <mdj@kenneth> - - * boot-9.scm (warn, scm-style-repl): Use C printer instead of `print'. - (make-record-type type-name fields): Temporarily remove support - for printing of records (not possible yet with C printer). - -Fri Sep 20 00:24:27 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm (file-exists?, file-is-directory): catch only - system-error, not every kind of error. - (scm-error): new procedure. - -Thu Sep 19 16:02:46 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * boot-9.scm: Formatting tweaks. - -Wed Sep 18 09:07:37 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm (%%handle-system-error key): remove the code for - SCM-style errors. handle the case that an unexpected number - of args are supplied. - (%%system-errors): removed. - (error): redefine using a throw with key and 4 args. - ('error): associate 'error, 'error-signal keys with - %%handle-system-error. - (%%default-error-handler): removed. - (signal-handler): throw with 4 args and use the error-signal key. - Create an error message instead of using numerical codes. - (%%bad-throw): call error instead of throw if key not found. - -Tue Sep 17 04:11:28 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm: initialize new error keys (see libguile/ChangeLog). - (%%handle-system-error key): check subr is not #f before printing. - Recognize %s (embed an argument using "display") and - %S (embed an argument using "write"). - -Sun Sep 15 03:55:35 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm (%%handle-system-error key): set args and rest to - the empty list if they are #f. - Initialize out-of-range as an error key. - -Sat Sep 14 03:41:15 1996 Gary Houston <ghouston@actrix.gen.nz> - - * PLUGIN/REQ: remove the "ice-9 lgh" line which causes a cycle. - - * boot-9.scm: remove leading %% from references to '%%system-error. - (%%handle-system-error): don't pass all the thrown arguments when - aborting, just the key and subr. - Remove the code to "Install default handlers for built-in errors." - Remove the definition of the syserror procedure. - Associate 'numerical-overflow with default handler. - -Fri Sep 13 04:58:11 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> - - * boot-9.scm: Name change: value-ref --> local-ref - resolved-ref --> nested-ref Motivation: conformance to the other - dictionary operators: list-ref operates on list, vector-ref - operates on vector, nested-ref operates on nested namespace, - local-ref operates on the local nested namespace. - -Sat Sep 7 06:44:47 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm (%%handle-system-error): recognise errors thrown - by lgh-error (fill-message etc.) - (fill-message): check first whether args is null. - (fill-message): bug fix and check that args is a list. - -Thu Sep 5 11:33:41 1996 Jim Blandy <jimb@floss.cyclic.com> - - * boot-9.scm: %load-path is initialized in C code now. - (implementation-vicinity, parse-path): Deleted, along with code to - initialize %load-path. - - * boot-9.scm (in-vicinity): If the vicinity doesn't end with a - "/", use one to separate it from the file. - -Thu Aug 29 23:05:11 1996 Thomas Morgan <tmorgan@gnu.ai.mit.edu> - - * boot-9.scm (%load-path): Add the site directory. - Add the directory named after the version number. - Prepend the version number to the other directories in the path. - Simplify by mapping the common prefix onto each item. - * Makefile.in (datadir, pkgdatadir, pkgverdatadir, subpkgdatadir, - sitedatadir): New definitions. - (libparent, libdir, install_path): Replaced by above. - (install): Create the above directories. - Put the source files into subpkgdatadir. - (uninstall): Remove the above directories. - -Thu Aug 29 21:48:47 1996 Jim Blandy <jimb@floss.cyclic.com> - - Don't use the PLUGIN system to gather information for the - Makefile's distribution and installation targets; just put it all - in the Makefile directly. - * PLUGIN/this.configure (scm_files, aux_files): Remove sections - for these. - * configure.in: Remove code that gets and substitutes scm_files and - aux_files. - * Makefile.in (scm_files, aux_files): Write out the list of files - here, where people expect to find them. - -Fri Aug 23 06:44:36 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> - - * boot-9.scm: Preliminary solution: optionally load the debug - module. Changed "gls" to "guile1.0b3". - - * debug.scm: New file: debug extensions. - -Wed Aug 21 13:06:56 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> - - * boot-9.scm (print-vector): Renamed weak-hash-table? --> - weak-key-hash-table?. (Again!) - -Tue Aug 20 07:31:39 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> - - * boot-9.scm (print-vector, macro-table, xformer-table): - Renamed weak-hash-table --> weak-key-hash-table. - - * poe.scm (funcq-memo): Renamed weak-hash-table --> - weak-key-hash-table. - -Sat Aug 3 06:16:35 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm (*null-device*): global constant from goonix. - (move->fdes): adjusted for boolean primitive-move->fdes. return - the modified port, always set revealed count to 1 (SCSH compatible). - (release-port-handle port): from goonix (SCSH compatible). - (%open-file): removed. - (open-input-file, open-output-file, file-exists?, file-is-directory?): - modified for open-file change (does not return #f). - -Thu Aug 1 02:52:42 1996 Jim Blandy <jimb@totoro.cyclic.com> - - * Makefile.in (dist-dir): New target for new dist system. - (manifest): Deleted. - * PLUGIN/this.configure (aux_files): Removed PLUGIN; it's a - directory, and needs special treatment in the dist-dir target. - -Thu Aug 1 09:00:21 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm: remove the wrappers for '%' system primitives, - now that they throw errors directly. - remove make-simple-wrapper and similar functions. - protect a call to getenv which may now throw an exception. - -Wed Jul 31 23:44:42 1996 Gary Houston <ghouston@actrix.gen.nz> - - * boot-9.scm (false-if-exception): new macro. - -Fri Apr 19 13:53:08 1996 Tom Lord <lord@beehive> - - * The more things change... - - diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am deleted file mode 100644 index 1647cffcc..000000000 --- a/ice-9/Makefile.am +++ /dev/null @@ -1,10 +0,0 @@ -## Process this file with automake to produce Makefile.in. - -AUTOMAKE_OPTIONS = foreign - -subpkgdatadir = $(pkgdatadir)/$(VERSION)/@module@ -subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \ -mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm - -## test.scm is not currently installed. -EXTRA_DIST = PLUGIN/REQ $(subpkgdata_DATA) test.scm diff --git a/ice-9/Makefile.in b/ice-9/Makefile.in deleted file mode 100644 index 65600dba8..000000000 --- a/ice-9/Makefile.in +++ /dev/null @@ -1,207 +0,0 @@ -# Makefile.in generated automatically by automake 1.1l from Makefile.am - -# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. -# This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - - -SHELL = /bin/sh - -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -VPATH = @srcdir@ -prefix = @prefix@ -exec_prefix = @exec_prefix@ - -bindir = @bindir@ -sbindir = @sbindir@ -libexecdir = @libexecdir@ -datadir = @datadir@ -sysconfdir = @sysconfdir@ -sharedstatedir = @sharedstatedir@ -localstatedir = @localstatedir@ -libdir = @libdir@ -infodir = @infodir@ -mandir = @mandir@ -includedir = @includedir@ -oldincludedir = /usr/include - -pkgdatadir = $(datadir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ - -top_builddir = . - -INSTALL = @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -transform = @program_transform_name@ -VERSION = @VERSION@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -module = @module@ -PACKAGE = @PACKAGE@ - -AUTOMAKE_OPTIONS = foreign - -subpkgdatadir = $(pkgdatadir)/$(VERSION)/@module@ -subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \ -mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm - -EXTRA_DIST = PLUGIN/REQ $(subpkgdata_DATA) test.scm -ACLOCAL = $(top_srcdir)/aclocal.m4 -mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs -CONFIG_CLEAN_FILES = -DATA = $(subpkgdata_DATA) - -DIST_COMMON = COPYING ChangeLog Makefile.am Makefile.in aclocal.m4 \ -configure configure.in - - -DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \ - $(TEXINFOS) $(MANS) $(EXTRA_DIST) - -TAR = tar -default: all - -.SUFFIXES: -$(srcdir)/Makefile.in: Makefile.am $(top_srcdir)/configure.in $(ACLOCAL) - cd $(top_srcdir) && automake --foreign Makefile - -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES) - cd $(top_builddir) \ - && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status - -$(srcdir)/aclocal.m4: configure.in - cd $(srcdir) && aclocal - -config.status: configure - $(SHELL) ./config.status --recheck -$(srcdir)/configure: configure.in $(ACLOCAL) $(CONFIGURE_DEPENDENCIES) - cd $(srcdir) && autoconf - -install-subpkgdataDATA: $(subpkgdata_DATA) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(subpkgdatadir) - @list="$(subpkgdata_DATA)"; for p in $$list; do \ - if test -f $(srcdir)/$$p; then \ - echo "$(INSTALL_DATA) $(srcdir)/$$p $(subpkgdatadir)/$$p"; \ - $(INSTALL_DATA) $(srcdir)/$$p $(subpkgdatadir)/$$p; \ - else if test -f $$p; then \ - echo "$(INSTALL_DATA) $$p $(subpkgdatadir)/$$p"; \ - $(INSTALL_DATA) $$p $(subpkgdatadir)/$$p; \ - fi; fi; \ - done - -uninstall-subpkgdataDATA: - list="$(subpkgdata_DATA)"; for p in $$list; do \ - rm -f $(subpkgdatadir)/$$p; \ - done -tags: TAGS -TAGS: - - -distdir = $(PACKAGE)-$(VERSION) -# This target untars the dist file and tries a VPATH configuration. Then -# it guarantees that the distribution is self-contained by making another -# tarfile. -distcheck: dist - rm -rf $(distdir) - $(TAR) zxf $(distdir).tar.gz - mkdir $(distdir)/=build - mkdir $(distdir)/=inst - dc_install_base=`cd $(distdir)/=inst && pwd`; \ - cd $(distdir)/=build \ - && ../configure --srcdir=.. --prefix=$$dc_install_base \ - && $(MAKE) \ - && $(MAKE) dvi \ - && $(MAKE) check \ - && $(MAKE) install \ - && $(MAKE) installcheck \ - && $(MAKE) dist - rm -rf $(distdir) - @echo "========================"; \ - echo "$(distdir).tar.gz is ready for distribution"; \ - echo "========================" -dist: distdir - -chmod -R a+r $(distdir) - $(TAR) chozf $(distdir).tar.gz $(distdir) - rm -rf $(distdir) -dist-all: distdir - -chmod -R a+r $(distdir) - $(TAR) chozf $(distdir).tar.gz $(distdir) - rm -rf $(distdir) -distdir: $(DISTFILES) - rm -rf $(distdir) - mkdir $(distdir) - -chmod 755 $(distdir) - here=`pwd`; distdir=`cd $(distdir) && pwd` \ - && cd $(srcdir) \ - && automake --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --foreign - $(mkinstalldirs) $(distdir)/PLUGIN - @for file in $(DISTFILES); do \ - d=$(srcdir); \ - test -f $(distdir)/$$file \ - || ln $$d/$$file $(distdir)/$$file 2> /dev/null \ - || cp -p $$d/$$file $(distdir)/$$file; \ - done -info: -dvi: -check: all - $(MAKE) -installcheck: -install-exec: - $(NORMAL_INSTALL) - -install-data: install-subpkgdataDATA - $(NORMAL_INSTALL) - -install: install-exec install-data all - @: - -uninstall: uninstall-subpkgdataDATA - -all: $(DATA) Makefile - -install-strip: - $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install -installdirs: - $(mkinstalldirs) $(subpkgdatadir) - - -mostlyclean-generic: - test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) - -clean-generic: - test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) - -distclean-generic: - rm -f Makefile $(DISTCLEANFILES) - rm -f config.cache config.log stamp-h - test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -maintainer-clean-generic: - test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) - test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) -mostlyclean: mostlyclean-generic - -clean: clean-generic mostlyclean - -distclean: distclean-generic clean - rm -f config.status - -maintainer-clean: maintainer-clean-generic distclean - @echo "This command is intended for maintainers to use;" - @echo "it deletes files that may require special tools to rebuild." - rm -f config.status - -.PHONY: default uninstall-subpkgdataDATA install-subpkgdataDATA tags \ -distdir info dvi installcheck install-exec install-data install \ -uninstall all installdirs mostlyclean-generic distclean-generic \ -clean-generic maintainer-clean-generic clean mostlyclean distclean \ -maintainer-clean - - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff --git a/ice-9/aclocal.m4 b/ice-9/aclocal.m4 deleted file mode 100644 index ace866913..000000000 --- a/ice-9/aclocal.m4 +++ /dev/null @@ -1,64 +0,0 @@ -dnl aclocal.m4 generated automatically by aclocal 1.1l - - -dnl Usage: AM_INIT_GUILE_MODULE(module-name) -dnl This macro will automatically get the guile version from the -dnl top-level srcdir, and will initialize automake. It also -dnl defines the `module' variable. -AC_DEFUN([AM_INIT_GUILE_MODULE],[ -. $srcdir/../GUILE-VERSION -AM_INIT_AUTOMAKE($PACKAGE, $VERSION) -AC_CONFIG_AUX_DIR(..) -module=[$1] -AC_SUBST(module)]) - -# Do all the work for Automake. This macro actually does too much -- -# some checks are only needed if your package does certain things. -# But this isn't really a big deal. - -# serial 1 - -dnl Usage: -dnl AM_INIT_AUTOMAKE(package,version) - -AC_DEFUN(AM_INIT_AUTOMAKE, -[AC_REQUIRE([AM_PROG_INSTALL]) -PACKAGE=[$1] -AC_SUBST(PACKAGE) -AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE") -VERSION=[$2] -AC_SUBST(VERSION) -AC_DEFINE_UNQUOTED(VERSION, "$VERSION") -AM_SANITY_CHECK -AC_ARG_PROGRAM -AC_PROG_MAKE_SET]) - - -# serial 1 - -AC_DEFUN(AM_PROG_INSTALL, -[AC_REQUIRE([AC_PROG_INSTALL]) -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' -AC_SUBST(INSTALL_SCRIPT)dnl -]) - -# -# Check to make sure that the build environment is sane. -# - -AC_DEFUN(AM_SANITY_CHECK, -[AC_MSG_CHECKING([whether build environment is sane]) -echo timestamp > conftestfile -# Do this in a subshell so we don't clobber the current shell's -# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? -if (set X `ls -t $srcdir/configure conftestfile`; test "[$]2" = conftestfile) -then - # Ok. - : -else - AC_MSG_ERROR([newly created file is older than distributed files! -Check your system clock]) -fi -rm -f conftest* -AC_MSG_RESULT(yes)]) - diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm deleted file mode 100644 index 9a5426bdc..000000000 --- a/ice-9/boot-9.scm +++ /dev/null @@ -1,3479 +0,0 @@ -;;; installed-scm-file - -;;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; - - -;;; This file is the first thing loaded into Guile. It adds many mundane -;;; definitions and a few that are interesting. -;;; -;;; The module system (hence the hierarchical namespace) are defined in this -;;; file. -;;; - - -;;; During Guile development, we want to use debugging evaluator and record -;;; positions of source expressions in boot-9.scm by default. - -(debug-options-interface (cons 'debug (debug-options-interface))) -(read-options-interface (cons 'positions (read-options-interface))) - - -;;; {Features} -;; - -(define (provide sym) - (if (not (memq sym *features*)) - (set! *features* (cons sym *features*)))) - - -;;; {R4RS compliance} - -(primitive-load-path "ice-9/r4rs.scm") - - -;;; {Simple Debugging Tools} -;; - - -;; peek takes any number of arguments, writes them to the -;; current ouput port, and returns the last argument. -;; It is handy to wrap around an expression to look at -;; a value each time is evaluated, e.g.: -;; -;; (+ 10 (troublesome-fn)) -;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn))) -;; - -(define (peek . stuff) - (newline) - (display ";;; ") - (write stuff) - (newline) - (car (last-pair stuff))) - -(define pk peek) - -(define (warn . stuff) - (with-output-to-port (current-error-port) - (lambda () - (newline) - (display ";;; WARNING ") - (display stuff) - (newline) - (car (last-pair stuff))))) - - -;;; {apply and call-with-current-continuation} -;;; -;;; These turn syntax, @apply and @call-with-current-continuation, -;;; into procedures. -;;; - -(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args)))) -(define (call-with-current-continuation proc) - (@call-with-current-continuation proc)) - - - -;;; {Trivial Functions} -;;; - -(define (id x) x) -(define (1+ n) (+ n 1)) -(define (-1+ n) (+ n -1)) -(define 1- -1+) -(define return-it noop) -(define (and=> value thunk) (and value (thunk value))) -(define (make-hash-table k) (make-vector k '())) - -;;; apply-to-args is functionally redunant with apply and, worse, -;;; is less general than apply since it only takes two arguments. -;;; -;;; On the other hand, apply-to-args is a syntacticly convenient way to -;;; perform binding in many circumstances when the "let" family of -;;; of forms don't cut it. E.g.: -;;; -;;; (apply-to-args (return-3d-mouse-coords) -;;; (lambda (x y z) -;;; ...)) -;;; - -(define (apply-to-args args fn) (apply fn args)) - - -;;; {Integer Math} -;;; - -(define (ipow-by-squaring x k acc proc) - (cond ((zero? k) acc) - ((= 1 k) (proc acc x)) - (else (logical:ipow-by-squaring (proc x x) - (quotient k 2) - (if (even? k) acc (proc acc x)) - proc)))) - -(define string-character-length string-length) - - - -;; A convenience function for combining flag bits. Like logior, but -;; handles the cases of 0 and 1 arguments. -;; -(define (flags . args) - (cond - ((null? args) 0) - ((null? (cdr args)) (car args)) - (else (apply logior args)))) - - -;;; {Symbol Properties} -;;; - -(define (symbol-property sym prop) - (let ((pair (assoc prop (symbol-pref sym)))) - (and pair (cdr pair)))) - -(define (set-symbol-property! sym prop val) - (let ((pair (assoc prop (symbol-pref sym)))) - (if pair - (set-cdr! pair val) - (symbol-pset! sym (acons prop val (symbol-pref sym)))))) - -(define (symbol-property-remove! sym prop) - (let ((pair (assoc prop (symbol-pref sym)))) - (if pair - (symbol-pset! sym (delq! pair (symbol-pref sym)))))) - - -;;; {Arrays} -;;; - -(begin - (define uniform-vector? array?) - (define make-uniform-vector dimensions->uniform-array) - ; (define uniform-vector-ref array-ref) - (define (uniform-vector-set! u i o) - (uniform-vector-set1! u o i)) - (define uniform-vector-fill! array-fill!) - (define uniform-vector-read! uniform-array-read!) - (define uniform-vector-write uniform-array-write) - - (define (make-array fill . args) - (dimensions->uniform-array args () fill)) - (define (make-uniform-array prot . args) - (dimensions->uniform-array args prot)) - (define (list->array ndim lst) - (list->uniform-array ndim '() lst)) - (define (list->uniform-vector prot lst) - (list->uniform-array 1 prot lst)) - (define (array-shape a) - (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) - (array-dimensions a)))) - - -;;; {Keywords} -;;; - -(define (symbol->keyword symbol) - (make-keyword-from-dash-symbol (symbol-append '- symbol))) - -(define (keyword->symbol kw) - (let ((sym (keyword-dash-symbol kw))) - (string->symbol (substring sym 1 (length sym))))) - -(define (kw-arg-ref args kw) - (let ((rem (member kw args))) - (and rem (pair? (cdr rem)) (cadr rem)))) - - -;;; {Print} -;;; MDJ 960919 <djurfeldt@nada.kth.se>: This code will probably be -;;; removed before the first release of Guile. Later releases may -;;; contain more fancy printing code. - -(define (print obj . args) - (let ((default-args (list (current-output-port) 0 0 default-print-style #f))) - (apply-to-args (append args (list-cdr-ref default-args (length args))) - (lambda (port depth length style table) - (cond - ((and table (print-table-ref table obj)) - ((print-style-tag-hook style 'eq-val) - obj port depth length style table)) - (else - (and table (print-table-add! table obj)) - (cond - ((print-style-max-depth? style depth) - ((print-style-excess-depth-hook style))) - ((print-style-max-length? style length) - ((print-style-excess-length-hook style))) - (else - ((print-style-hook style obj) - obj port depth length style table))))))))) - -(define (make-print-style) (make-vector 59 '())) - -(define (extend-print-style! style utag printer) - (hashq-set! style utag printer)) - -(define (print-style-hook style obj) - (let ((type-tag (tag obj))) - (or (hashq-ref style type-tag) - (hashq-ref style (logand type-tag 255)) - print-obj))) - -(define (print-style-tag-hook style type-tag) - (or (hashq-ref style type-tag) - print-obj)) - -(define (print-style-max-depth? style d) #f) -(define (print-style-max-length? style l) #f) -(define (print-style-excess-length-hook style) - (hashq-ref style 'excess-length-hook)) -(define (print-style-excess-depth-hook style) - (hashq-ref style 'excess-depth-hook)) - -(define (make-print-table) (make-vector 59 '())) -(define (print-table-ref table obj) (hashq-ref table obj)) -(define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref))) - -(define (print-obj obj port depth length style table) (write obj port)) - -(define (print-pair pair port depth length style table) - (if (= 0 length) - (display #\( port)) - - (print (car pair) port (+ 1 depth) 0 style table) - - (cond - ((and (pair? (cdr pair)) - (or (not table) - (not (print-table-ref table (cdr pair))))) - - (display #\space port) - (print (cdr pair) port depth (+ 1 length) style table)) - - ((null? (cdr pair)) (display #\) port)) - - (else (display " . " port) - (print (cdr pair) port (+ 1 depth) 0 - style table) - (display #\) port)))) - -(define (print-vector obj port depth length style table) - (if (= 0 length) - (cond - ((weak-key-hash-table? obj) (display "#wh(" port)) - ((weak-value-hash-table? obj) (display "#whv(" port)) - ((doubly-weak-hash-table? obj) (display "#whd(" port)) - (else (display "#(" port)))) - - (if (< length (vector-length obj)) - (print (vector-ref obj length) port (+ 1 depth) 0 style table)) - - (cond - ((>= (+ 1 length) (vector-length obj)) (display #\) port)) - (else (display #\space port) - (print obj port depth - (+ 1 length) - style table)))) - -(define default-print-style (make-print-style)) - -(extend-print-style! default-print-style utag_vector print-vector) -(extend-print-style! default-print-style utag_wvect print-vector) -(extend-print-style! default-print-style utag_pair print-pair) -(extend-print-style! default-print-style 'eq-val - (lambda (obj port depth length style table) - (if (symbol? obj) - (display obj) - (begin - (display "##" port) - (display (print-table-ref table obj)))))) - - -;;; {Records} -;;; - -(define record-type-vtable (make-vtable-vtable "prpr" 0)) - -(define (record-type? obj) - (and (struct? obj) (eq? record-type-vtable (struct-vtable obj)))) - -(define (make-record-type type-name fields . opt) - (let ((printer-fn (and (pair? opt) (car opt)))) - (let ((struct (make-struct record-type-vtable 0 - (make-struct-layout - (apply symbol-append - (map (lambda (f) "pw") fields))) - type-name - (copy-tree fields)))) - ;; !!! leaks printer functions - ;; MDJ 960919 <djurfeldt@nada.kth.se>: *fixme* need to make it - ;; possible to print records nicely. - ;(if printer-fn -; (extend-print-style! default-print-style -; (logior utag_struct_base (ash (struct-vtable-tag struct) 8)) -; printer-fn)) - struct))) - -(define (record-type-name obj) - (if (record-type? obj) - (struct-ref obj struct-vtable-offset) - (error 'not-a-record-type obj))) - -(define (record-type-fields obj) - (if (record-type? obj) - (struct-ref obj (+ 1 struct-vtable-offset)) - (error 'not-a-record-type obj))) - -(define (record-constructor rtd . opt) - (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd)))) - (eval `(lambda ,field-names - (make-struct ',rtd 0 ,@(map (lambda (f) - (if (memq f field-names) - f - #f)) - (record-type-fields rtd))))))) - -(define (record-predicate rtd) - (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj))))) - -(define (record-accessor rtd field-name) - (let* ((pos (list-index (record-type-fields rtd) field-name))) - (if (not pos) - (error 'no-such-field field-name)) - (eval `(lambda (obj) - (and (eq? ',rtd (record-type-descriptor obj)) - (struct-ref obj ,pos)))))) - -(define (record-modifier rtd field-name) - (let* ((pos (list-index (record-type-fields rtd) field-name))) - (if (not pos) - (error 'no-such-field field-name)) - (eval `(lambda (obj val) - (and (eq? ',rtd (record-type-descriptor obj)) - (struct-set! obj ,pos val)))))) - - -(define (record? obj) - (and (struct? obj) (record-type? (struct-vtable obj)))) - -(define (record-type-descriptor obj) - (if (struct? obj) - (struct-vtable obj) - (error 'not-a-record obj))) - -(provide 'record) - - -;;; {Booleans} -;;; - -(define (->bool x) (not (not x))) - - -;;; {Symbols} -;;; - -(define (symbol-append . args) - (string->symbol (apply string-append args))) - -(define (list->symbol . args) - (string->symbol (apply list->string args))) - -(define (symbol . args) - (string->symbol (apply string args))) - -(define (obarray-symbol-append ob . args) - (string->obarray-symbol (apply string-append ob args))) - -(define obarray-gensym - (let ((n -1)) - (lambda (obarray . opt) - (if (null? opt) - (set! opt '(%%gensym))) - (let loop ((proposed-name (apply string-append opt))) - (if (string->obarray-symbol obarray proposed-name #t) - (loop (apply string-append (append opt (begin (set! n (1+ n)) (list (number->string n)))))) - (string->obarray-symbol obarray proposed-name)))))) - -(define (gensym . args) (apply obarray-gensym #f args)) - - -;;; {Lists} -;;; - -(define (list-index l k) - (let loop ((n 0) - (l l)) - (and (not (null? l)) - (if (eq? (car l) k) - n - (loop (+ n 1) (cdr l)))))) - -(define (make-list n init) - (let loop ((answer '()) - (n n)) - (if (<= n 0) - answer - (loop (cons init answer) (- n 1))))) - - - -;;; {and-map, or-map, and map-in-order} -;;; -;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) -;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...) -;;; (map-in-order fn lst) is like (map fn lst) but definately in order of lst. -;;; - -;; and-map f l -;; -;; Apply f to successive elements of l until exhaustion or f returns #f. -;; If returning early, return #f. Otherwise, return the last value returned -;; by f. If f has never been called because l is empty, return #t. -;; -(define (and-map f lst) - (let loop ((result #t) - (l lst)) - (and result - (or (and (null? l) - result) - (loop (f (car l)) (cdr l)))))) - -;; or-map f l -;; -;; Apply f to successive elements of l until exhaustion or while f returns #f. -;; If returning early, return the return value of f. -;; -(define (or-map f lst) - (let loop ((result #f) - (l lst)) - (or result - (and (not (null? l)) - (loop (f (car l)) (cdr l)))))) - -;; map-in-order -;; -;; Like map, but guaranteed to process the list in order. -;; -(define (map-in-order fn l) - (if (null? l) - '() - (cons (fn (car l)) - (map-in-order fn (cdr l))))) - - -;;; {Files} -;;; !!!! these should be implemented using Tcl commands, not fports. -;;; - -(define (feature? feature) - (and (memq feature *features*) #t)) - -;; Using the vector returned by stat directly is probably not a good -;; idea (it could just as well be a record). Hence some accessors. -(define (stat:dev f) (vector-ref f 0)) -(define (stat:ino f) (vector-ref f 1)) -(define (stat:mode f) (vector-ref f 2)) -(define (stat:nlink f) (vector-ref f 3)) -(define (stat:uid f) (vector-ref f 4)) -(define (stat:gid f) (vector-ref f 5)) -(define (stat:rdev f) (vector-ref f 6)) -(define (stat:size f) (vector-ref f 7)) -(define (stat:atime f) (vector-ref f 8)) -(define (stat:mtime f) (vector-ref f 9)) -(define (stat:ctime f) (vector-ref f 10)) -(define (stat:blksize f) (vector-ref f 11)) -(define (stat:blocks f) (vector-ref f 12)) - -;; derived from stat mode. -(define (stat:type f) (vector-ref f 13)) -(define (stat:perms f) (vector-ref f 14)) - -(define file-exists? - (if (feature? 'posix) - (lambda (str) - (access? str F_OK)) - (lambda (str) - (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ)) - (lambda args #f)))) - (if port (begin (close-port port) #t) - #f))))) - -(define file-is-directory? - (if (feature? 'i/o-extensions) - (lambda (str) - (eq? (stat:type (stat str)) 'directory)) - (lambda (str) - (display str) - (newline) - (let ((port (catch 'system-error - (lambda () (open-file (string-append str "/.") - OPEN_READ)) - (lambda args #f)))) - (if port (begin (close-port port) #t) - #f))))) - -(define (has-suffix? str suffix) - (let ((sufl (string-length suffix)) - (sl (string-length str))) - (and (> sl sufl) - (string=? (substring str (- sl sufl) sl) suffix)))) - - -;;; {Error Handling} -;;; - -(define (error . args) - (save-stack) - (if (null? args) - (scm-error 'misc-error #f "?" #f #f) - (let loop ((msg "%s") - (rest (cdr args))) - (if (not (null? rest)) - (loop (string-append msg " %S") - (cdr rest)) - (scm-error 'misc-error #f msg args #f))))) - -(define (scm-error key subr message args rest) - (throw key subr message args rest)) - -;; bad-throw is the hook that is called upon a throw to a an unhandled -;; key (unless the throw has four arguments, in which case -;; it's usually interpreted as an error throw.) -;; If the key has a default handler (a throw-handler-default property), -;; it is applied to the throw. -;; -(define (bad-throw key . args) - (let ((default (symbol-property key 'throw-handler-default))) - (or (and default (apply default key args)) - (apply error "unhandled-exception:" key args)))) - -;; mostly obsolete. -;; A number of internally defined error types were represented -;; as integers. Here is the mapping to symbolic names -;; and error messages. -;; -;(define %%system-errors -; '((-1 UNKNOWN "Unknown error") -; (0 ARGn "Wrong type argument to ") -; (1 ARG1 "Wrong type argument in position 1 to ") -; (2 ARG2 "Wrong type argument in position 2 to ") -; (3 ARG3 "Wrong type argument in position 3 to ") -; (4 ARG4 "Wrong type argument in position 4 to ") -; (5 ARG5 "Wrong type argument in position 5 to ") -; (6 ARG5 "Wrong type argument in position 5 to ") -; (7 ARG5 "Wrong type argument in position 5 to ") -; (8 WNA "Wrong number of arguments to ") -; (9 OVFLOW "Numerical overflow to ") -; (10 OUTOFRANGE "Argument out of range to ") -; (11 NALLOC "Could not allocate to ") -; (12 STACK_OVFLOW "Stack overflow") -; (13 EXIT "Exit (internal error?).") -; (14 HUP_SIGNAL "hang-up") -; (15 INT_SIGNAL "user interrupt") -; (16 FPE_SIGNAL "arithmetic error") -; (17 BUS_SIGNAL "bus error") -; (18 SEGV_SIGNAL "segmentation violation") -; (19 ALRM_SIGNAL "alarm") -; (20 GC_SIGNAL "gc") -; (21 TICK_SIGNAL "tick"))) - - -(define (timer-thunk) #t) -(define (gc-thunk) #t) -(define (alarm-thunk) #t) - -(define (signal-handler n) - (let* ( - ;; these numbers are set in libguile, not the same as those - ;; interned in posix.c for SIGSEGV etc. - ;; - (signal-messages `((14 . "hang-up") - (15 . "user interrupt") - (16 . "arithmetic error") - (17 . "bus error") - (18 . "segmentation violation")))) - (cond - ((= n 21) (unmask-signals) (timer-thunk)) - ((= n 20) (unmask-signals) (gc-thunk)) - ((= n 19) (unmask-signals) (alarm-thunk)) - (else (set! the-last-stack - (make-stack #t - (list-ref (list %hup-thunk - %int-thunk - %fpe-thunk - %bus-thunk - %segv-thunk) - (- n 14)) - 1)) - (set! stack-saved? #t) - (if (not (and (memq 'debug (debug-options-interface)) - (eq? (stack-id the-last-stack) 'repl-stack))) - (set! the-last-stack #f)) - (unmask-signals) - (let ((sig-pair (assoc n signal-messages))) - (scm-error 'error-signal #f - (cdr (or sig-pair - (cons n "Unknown signal: %s"))) - (if sig-pair - #f - (list n)) - (list n))))))) - - -;;; {Non-polymorphic versions of POSIX functions} - -(define (getgrnam name) (getgr name)) -(define (getgrgid id) (getgr id)) -(define (gethostbyaddr addr) (gethost addr)) -(define (gethostbyname name) (gethost name)) -(define (getnetbyaddr addr) (getnet addr)) -(define (getnetbyname name) (getnet name)) -(define (getprotobyname name) (getproto name)) -(define (getprotobynumber addr) (getproto addr)) -(define (getpwnam name) (getpw name)) -(define (getpwuid uid) (getpw uid)) -(define (getservbyname name proto) (%getserv name proto)) -(define (getservbyport port proto) (%getserv port proto)) -(define (endgrent) (setgr)) -(define (endhostent) (sethost)) -(define (endnetent) (setnet)) -(define (endprotoent) (setproto)) -(define (endpwent) (setpw)) -(define (endservent) (setserv)) -(define (file-position . args) (apply ftell args)) -(define (file-set-position . args) (apply fseek args)) -(define (getgrent) (getgr)) -(define (gethostent) (gethost)) -(define (getnetent) (getnet)) -(define (getprotoent) (getproto)) -(define (getpwent) (getpw)) -(define (getservent) (getserv)) -(define (reopen-file . args) (apply freopen args)) -(define (setgrent arg) (setgr arg)) -(define (sethostent arg) (sethost arg)) -(define (setnetent arg) (setnet arg)) -(define (setprotoent arg) (setproto arg)) -(define (setpwent arg) (setpw arg)) -(define (setservent arg) (setserv arg)) - -(define (move->fdes port fd) - (primitive-move->fdes port fd) - (set-port-revealed! port 1) - port) - -(define (release-port-handle port) - (let ((revealed (port-revealed port))) - (if (> revealed 0) - (set-port-revealed! port (- revealed 1))))) - - -;;; {Load Paths} -;;; - -;;; Here for backward compatability -;; -(define scheme-file-suffix (lambda () ".scm")) - -(define (in-vicinity vicinity file) - (let ((tail (let ((len (string-length vicinity))) - (if (zero? len) #f - (string-ref vicinity (- len 1)))))) - (string-append vicinity - (if (eq? tail #\/) "" "/") - file))) - - -;;; {Loading by paths} - -;;; Load a Scheme source file named NAME, searching for it in the -;;; directories listed in %load-path, and applying each of the file -;;; name extensions listed in %load-extensions. -(define (load-from-path name) - (start-stack 'load-stack - (primitive-load-path name #t read-sharp))) - - - -;;; {Transcendental Functions} -;;; -;;; Derived from "Transcen.scm", Complex trancendental functions for SCM. -;;; Copyright (C) 1992, 1993 Jerry D. Hedden. -;;; See the file `COPYING' for terms applying to this program. -;;; - -(define (exp z) - (if (real? z) ($exp z) - (make-polar ($exp (real-part z)) (imag-part z)))) - -(define (log z) - (if (and (real? z) (>= z 0)) - ($log z) - (make-rectangular ($log (magnitude z)) (angle z)))) - -(define (sqrt z) - (if (real? z) - (if (negative? z) (make-rectangular 0 ($sqrt (- z))) - ($sqrt z)) - (make-polar ($sqrt (magnitude z)) (/ (angle z) 2)))) - -(define expt - (let ((integer-expt integer-expt)) - (lambda (z1 z2) - (cond ((exact? z2) - (integer-expt z1 z2)) - ((and (real? z2) (real? z1) (>= z1 0)) - ($expt z1 z2)) - (else - (exp (* z2 (log z1)))))))) - -(define (sinh z) - (if (real? z) ($sinh z) - (let ((x (real-part z)) (y (imag-part z))) - (make-rectangular (* ($sinh x) ($cos y)) - (* ($cosh x) ($sin y)))))) -(define (cosh z) - (if (real? z) ($cosh z) - (let ((x (real-part z)) (y (imag-part z))) - (make-rectangular (* ($cosh x) ($cos y)) - (* ($sinh x) ($sin y)))))) -(define (tanh z) - (if (real? z) ($tanh z) - (let* ((x (* 2 (real-part z))) - (y (* 2 (imag-part z))) - (w (+ ($cosh x) ($cos y)))) - (make-rectangular (/ ($sinh x) w) (/ ($sin y) w))))) - -(define (asinh z) - (if (real? z) ($asinh z) - (log (+ z (sqrt (+ (* z z) 1)))))) - -(define (acosh z) - (if (and (real? z) (>= z 1)) - ($acosh z) - (log (+ z (sqrt (- (* z z) 1)))))) - -(define (atanh z) - (if (and (real? z) (> z -1) (< z 1)) - ($atanh z) - (/ (log (/ (+ 1 z) (- 1 z))) 2))) - -(define (sin z) - (if (real? z) ($sin z) - (let ((x (real-part z)) (y (imag-part z))) - (make-rectangular (* ($sin x) ($cosh y)) - (* ($cos x) ($sinh y)))))) -(define (cos z) - (if (real? z) ($cos z) - (let ((x (real-part z)) (y (imag-part z))) - (make-rectangular (* ($cos x) ($cosh y)) - (- (* ($sin x) ($sinh y))))))) -(define (tan z) - (if (real? z) ($tan z) - (let* ((x (* 2 (real-part z))) - (y (* 2 (imag-part z))) - (w (+ ($cos x) ($cosh y)))) - (make-rectangular (/ ($sin x) w) (/ ($sinh y) w))))) - -(define (asin z) - (if (and (real? z) (>= z -1) (<= z 1)) - ($asin z) - (* -i (asinh (* +i z))))) - -(define (acos z) - (if (and (real? z) (>= z -1) (<= z 1)) - ($acos z) - (+ (/ (angle -1) 2) (* +i (asinh (* +i z)))))) - -(define (atan z . y) - (if (null? y) - (if (real? z) ($atan z) - (/ (log (/ (- +i z) (+ +i z))) +2i)) - ($atan2 z (car y)))) - -(set! abs magnitude) - - -;;; {User Settable Hooks} -;;; -;;; Parts of the C code check the bindings of these variables. -;;; - -(define ticks-interrupt #f) -(define user-interrupt #f) -(define alarm-interrupt #f) -(define out-of-storage #f) -(define could-not-open #f) -(define end-of-program #f) -(define hang-up #f) -(define arithmetic-error #f) -(define read-sharp #f) - - - -;;; {Reader Extensions} -;;; - -;;; Reader code for various "#c" forms. -;;; - -(define (parse-path-symbol s) - (define (separate-fields-discarding-char ch str ret) - (let loop ((fields '()) - (str str)) - (cond - ((string-rindex str ch) - => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 pos)) fields) - (make-shared-substring str 0 pos)))) - (else (ret (cons str fields)))))) - (separate-fields-discarding-char #\/ - s - (lambda (fields) - (map string->symbol fields)))) - - -(define (%read-sharp c port) - (define (barf) - (error "unknown # object" c)) - - (case c - ((#\/) (let ((look (peek-char port))) - (if (or (eof-object? look) - (and (char? look) - (or (char-whitespace? look) - (string-index ")" look)))) - '() - (parse-path-symbol (read port #t read-sharp))))) - ((#\') (read port #t read-sharp)) - ((#\.) (eval (read port #t read-sharp))) - ((#\b) (read:uniform-vector #t port)) - ((#\a) (read:uniform-vector #\a port)) - ((#\u) (read:uniform-vector 1 port)) - ((#\e) (read:uniform-vector -1 port)) - ((#\s) (read:uniform-vector 1.0 port)) - ((#\i) (read:uniform-vector 1/3 port)) - ((#\c) (read:uniform-vector 0+i port)) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (read:array c port)) - (else (barf)))) - -(define (read:array digit port) - (define chr0 (char->integer #\0)) - (let ((rank (let readnum ((val (- (char->integer digit) chr0))) - (if (char-numeric? (peek-char port)) - (readnum (+ (* 10 val) - (- (char->integer (read-char port)) chr0))) - val))) - (prot (if (eq? #\( (peek-char port)) - '() - (let ((c (read-char port))) - (case c ((#\b) #t) - ((#\a) #\a) - ((#\u) 1) - ((#\e) -1) - ((#\s) 1.0) - ((#\i) 1/3) - ((#\c) 0+i) - (else (error "read:array unknown option " c))))))) - (if (eq? (peek-char port) #\() - (list->uniform-array rank prot (read port #t read-sharp)) - (error "read:array list not found")))) - -(define (read:uniform-vector proto port) - (if (eq? #\( (peek-char port)) - (list->uniform-array 1 proto (read port #t read-sharp)) - (error "read:uniform-vector list not found"))) - - -(define read-sharp (lambda a (apply %read-sharp a))) - - - -;;; {Dynamic Roots} -;;; - -; mystery integers passed dynamic root error handlers -(define repl-quit -1) -(define repl-abort -2) - - - -;;; {Command Line Options} -;;; - -(define (get-option argv kw-opts kw-args return) - (cond - ((null? argv) - (return #f #f argv)) - - ((or (not (eq? #\- (string-ref (car argv) 0))) - (eq? (string-length (car argv)) 1)) - (return 'normal-arg (car argv) (cdr argv))) - - ((eq? #\- (string-ref (car argv) 1)) - (let* ((kw-arg-pos (or (string-index (car argv) #\=) - (string-length (car argv)))) - (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos))) - (kw-opt? (member kw kw-opts)) - (kw-arg? (member kw kw-args)) - (arg (or (and (not (eq? kw-arg-pos (string-length (car argv)))) - (substring (car argv) - (+ kw-arg-pos 1) - (string-length (car argv)))) - (and kw-arg? - (begin (set! argv (cdr argv)) (car argv)))))) - (if (or kw-opt? kw-arg?) - (return kw arg (cdr argv)) - (return 'usage-error kw (cdr argv))))) - - (else - (let* ((char (substring (car argv) 1 2)) - (kw (symbol->keyword char))) - (cond - - ((member kw kw-opts) - (let* ((rest-car (substring (car argv) 2 (string-length (car argv)))) - (new-argv (if (= 0 (string-length rest-car)) - (cdr argv) - (cons (string-append "-" rest-car) (cdr argv))))) - (return kw #f new-argv))) - - ((member kw kw-args) - (let* ((rest-car (substring (car argv) 2 (string-length (car argv)))) - (arg (if (= 0 (string-length rest-car)) - (cadr argv) - rest-car)) - (new-argv (if (= 0 (string-length rest-car)) - (cddr argv) - (cdr argv)))) - (return kw arg new-argv))) - - (else (return 'usage-error kw argv))))))) - -(define (for-next-option proc argv kw-opts kw-args) - (let loop ((argv argv)) - (get-option argv kw-opts kw-args - (lambda (opt opt-arg argv) - (and opt (proc opt opt-arg argv loop)))))) - -(define (display-usage-report kw-desc) - (for-each - (lambda (kw) - (or (eq? (car kw) #t) - (eq? (car kw) 'else) - (let* ((opt-desc kw) - (help (cadr opt-desc)) - (opts (car opt-desc)) - (opts-proper (if (string? (car opts)) (cdr opts) opts)) - (arg-name (if (string? (car opts)) - (string-append "<" (car opts) ">") - "")) - (left-part (string-append - (with-output-to-string - (lambda () - (map (lambda (x) (display (keyword-symbol x)) (display " ")) - opts-proper))) - arg-name)) - (middle-part (if (and (< (length left-part) 30) - (< (length help) 40)) - (make-string (- 30 (length left-part)) #\ ) - "\n\t"))) - (display left-part) - (display middle-part) - (display help) - (newline)))) - kw-desc)) - - - -(define (delq-all! obj l) - (let ((answer (cons '() l))) - (let loop ((pos answer)) - (cond - ((null? (cdr pos)) (cdr answer)) - ((eq? (cadr pos) obj) (set-cdr! pos (cddr pos)) - (loop pos)) - (else (loop (cdr pos))))))) - -(define (transform-usage-lambda cases) - (let* ((raw-usage (delq! 'else (map car cases))) - (usage-sans-specials (map (lambda (x) - (or (and (not (list? x)) x) - (and (symbol? (car x)) #t) - (and (boolean? (car x)) #t) - x)) - raw-usage)) - (usage-desc (delq-all! #t usage-sans-specials)) - (kw-desc (map car usage-desc)) - (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc))) - (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc))) - (transmogrified-cases (map (lambda (case) - (cons (let ((opts (car case))) - (if (or (boolean? opts) (eq? 'else opts)) - opts - (cond - ((symbol? (car opts)) opts) - ((boolean? (car opts)) opts) - ((string? (caar opts)) (cdar opts)) - (else (car opts))))) - (cdr case))) - cases))) - `(let ((%display-usage (lambda () (display-usage-report ',usage-desc)))) - (lambda (%argv) - (let %next-arg ((%argv %argv)) - (get-option %argv - ',kw-opts - ',kw-args - (lambda (%opt %arg %new-argv) - (case %opt - ,@ transmogrified-cases)))))))) - - - - -;;; {Low Level Modules} -;;; -;;; These are the low level data structures for modules. -;;; -;;; !!! warning: The interface to lazy binder procedures is going -;;; to be changed in an incompatible way to permit all the basic -;;; module ops to be virtualized. -;;; -;;; (make-module size use-list lazy-binding-proc) => module -;;; module-{obarray,uses,binder}[|-set!] -;;; (module? obj) => [#t|#f] -;;; (module-locally-bound? module symbol) => [#t|#f] -;;; (module-bound? module symbol) => [#t|#f] -;;; (module-symbol-locally-interned? module symbol) => [#t|#f] -;;; (module-symbol-interned? module symbol) => [#t|#f] -;;; (module-local-variable module symbol) => [#<variable ...> | #f] -;;; (module-variable module symbol) => [#<variable ...> | #f] -;;; (module-symbol-binding module symbol opt-value) -;;; => [ <obj> | opt-value | an error occurs ] -;;; (module-make-local-var! module symbol) => #<variable...> -;;; (module-add! module symbol var) => unspecified -;;; (module-remove! module symbol) => unspecified -;;; (module-for-each proc module) => unspecified -;;; (make-scm-module) => module ; a lazy copy of the symhash module -;;; (set-current-module module) => unspecified -;;; (current-module) => #<module...> -;;; -;;; - - -;;; {Printing Modules} -;; This is how modules are printed. You can re-define it. -;; -(define (%print-module mod port depth length style table) - (display "#<" port) - (display (or (module-kind mod) "module") port) - (let ((name (module-name mod))) - (if name - (begin - (display " " port) - (display name port)))) - (display " " port) - (display (number->string (object-address mod) 16) port) - (display ">" port)) - -;; module-type -;; -;; A module is characterized by an obarray in which local symbols -;; are interned, a list of modules, "uses", from which non-local -;; bindings can be inherited, and an optional lazy-binder which -;; is a (CLOSURE module symbol) which, as a last resort, can provide -;; bindings that would otherwise not be found locally in the module. -;; -(define module-type - (make-record-type 'module '(obarray uses binder eval-closure name kind) - %print-module)) - -;; make-module &opt size uses binder -;; -;; Create a new module, perhaps with a particular size of obarray, -;; initial uses list, or binding procedure. -;; -(define make-module - (lambda args - - (define (parse-arg index default) - (if (> (length args) index) - (list-ref args index) - default)) - - (if (> (length args) 3) - (error "Too many args to make-module." args)) - - (let ((size (parse-arg 0 1021)) - (uses (parse-arg 1 '())) - (binder (parse-arg 2 #f))) - - (if (not (integer? size)) - (error "Illegal size to make-module." size)) - (if (not (and (list? uses) - (and-map module? uses))) - (error "Incorrect use list." uses)) - (if (and binder (not (procedure? binder))) - (error - "Lazy-binder expected to be a procedure or #f." binder)) - - (let ((module (module-constructor (make-vector size '()) - uses binder #f #f #f))) - - ;; We can't pass this as an argument to module-constructor, - ;; because we need it to close over a pointer to the module - ;; itself. - (set-module-eval-closure! module - (lambda (symbol define?) - (if define? - (module-make-local-var! module symbol) - (module-variable module symbol)))) - - module)))) - -(define module-constructor (record-constructor module-type)) -(define module-obarray (record-accessor module-type 'obarray)) -(define set-module-obarray! (record-modifier module-type 'obarray)) -(define module-uses (record-accessor module-type 'uses)) -(define set-module-uses! (record-modifier module-type 'uses)) -(define module-binder (record-accessor module-type 'binder)) -(define set-module-binder! (record-modifier module-type 'binder)) -(define module-eval-closure (record-accessor module-type 'eval-closure)) -(define set-module-eval-closure! (record-modifier module-type 'eval-closure)) -(define module-name (record-accessor module-type 'name)) -(define set-module-name! (record-modifier module-type 'name)) -(define module-kind (record-accessor module-type 'kind)) -(define set-module-kind! (record-modifier module-type 'kind)) -(define module? (record-predicate module-type)) - - -(define (eval-in-module exp module) - (eval2 exp (module-eval-closure module))) - - -;;; {Module Searching in General} -;;; -;;; We sometimes want to look for properties of a symbol -;;; just within the obarray of one module. If the property -;;; holds, then it is said to hold ``locally'' as in, ``The symbol -;;; DISPLAY is locally rebound in the module `safe-guile'.'' -;;; -;;; -;;; Other times, we want to test for a symbol property in the obarray -;;; of M and, if it is not found there, try each of the modules in the -;;; uses list of M. This is the normal way of testing for some -;;; property, so we state these properties without qualification as -;;; in: ``The symbol 'fnord is interned in module M because it is -;;; interned locally in module M2 which is a member of the uses list -;;; of M.'' -;;; - -;; module-search fn m -;; -;; return the first non-#f result of FN applied to M and then to -;; the modules in the uses of m, and so on recursively. If all applications -;; return #f, then so does this function. -;; -(define (module-search fn m v) - (define (loop pos) - (and (pair? pos) - (or (module-search fn (car pos) v) - (loop (cdr pos))))) - (or (fn m v) - (loop (module-uses m)))) - - -;;; {Is a symbol bound in a module?} -;;; -;;; Symbol S in Module M is bound if S is interned in M and if the binding -;;; of S in M has been set to some well-defined value. -;;; - -;; module-locally-bound? module symbol -;; -;; Is a symbol bound (interned and defined) locally in a given module? -;; -(define (module-locally-bound? m v) - (let ((var (module-local-variable m v))) - (and var - (variable-bound? var)))) - -;; module-bound? module symbol -;; -;; Is a symbol bound (interned and defined) anywhere in a given module -;; or its uses? -;; -(define (module-bound? m v) - (module-search module-locally-bound? m v)) - -;;; {Is a symbol interned in a module?} -;;; -;;; Symbol S in Module M is interned if S occurs in -;;; of S in M has been set to some well-defined value. -;;; -;;; It is possible to intern a symbol in a module without providing -;;; an initial binding for the corresponding variable. This is done -;;; with: -;;; (module-add! module symbol (make-undefined-variable)) -;;; -;;; In that case, the symbol is interned in the module, but not -;;; bound there. The unbound symbol shadows any binding for that -;;; symbol that might otherwise be inherited from a member of the uses list. -;;; - -(define (module-obarray-get-handle ob key) - ((if (symbol? key) hashq-get-handle hash-get-handle) ob key)) - -(define (module-obarray-ref ob key) - ((if (symbol? key) hashq-ref hash-ref) ob key)) - -(define (module-obarray-set! ob key val) - ((if (symbol? key) hashq-set! hash-set!) ob key val)) - -(define (module-obarray-remove! ob key) - ((if (symbol? key) hashq-remove! hash-remove!) ob key)) - -;; module-symbol-locally-interned? module symbol -;; -;; is a symbol interned (not neccessarily defined) locally in a given module -;; or its uses? Interned symbols shadow inherited bindings even if -;; they are not themselves bound to a defined value. -;; -(define (module-symbol-locally-interned? m v) - (not (not (module-obarray-get-handle (module-obarray m) v)))) - -;; module-symbol-interned? module symbol -;; -;; is a symbol interned (not neccessarily defined) anywhere in a given module -;; or its uses? Interned symbols shadow inherited bindings even if -;; they are not themselves bound to a defined value. -;; -(define (module-symbol-interned? m v) - (module-search module-symbol-locally-interned? m v)) - - -;;; {Mapping modules x symbols --> variables} -;;; - -;; module-local-variable module symbol -;; return the local variable associated with a MODULE and SYMBOL. -;; -;;; This function is very important. It is the only function that can -;;; return a variable from a module other than the mutators that store -;;; new variables in modules. Therefore, this function is the location -;;; of the "lazy binder" hack. -;;; -;;; If symbol is defined in MODULE, and if the definition binds symbol -;;; to a variable, return that variable object. -;;; -;;; If the symbols is not found at first, but the module has a lazy binder, -;;; then try the binder. -;;; -;;; If the symbol is not found at all, return #f. -;;; -(define (module-local-variable m v) -; (caddr -; (list m v - (let ((b (module-obarray-ref (module-obarray m) v))) - (or (and (variable? b) b) - (and (module-binder m) - ((module-binder m) m v #f))))) -;)) - -;; module-variable module symbol -;; -;; like module-local-variable, except search the uses in the -;; case V is not found in M. -;; -(define (module-variable m v) - (module-search module-local-variable m v)) - - -;;; {Mapping modules x symbols --> bindings} -;;; -;;; These are similar to the mapping to variables, except that the -;;; variable is dereferenced. -;;; - -;; module-symbol-binding module symbol opt-value -;; -;; return the binding of a variable specified by name within -;; a given module, signalling an error if the variable is unbound. -;; If the OPT-VALUE is passed, then instead of signalling an error, -;; return OPT-VALUE. -;; -(define (module-symbol-local-binding m v . opt-val) - (let ((var (module-local-variable m v))) - (if var - (variable-ref var) - (if (not (null? opt-val)) - (car opt-val) - (error "Locally unbound variable." v))))) - -;; module-symbol-binding module symbol opt-value -;; -;; return the binding of a variable specified by name within -;; a given module, signalling an error if the variable is unbound. -;; If the OPT-VALUE is passed, then instead of signalling an error, -;; return OPT-VALUE. -;; -(define (module-symbol-binding m v . opt-val) - (let ((var (module-variable m v))) - (if var - (variable-ref var) - (if (not (null? opt-val)) - (car opt-val) - (error "Unbound variable." v))))) - - - -;;; {Adding Variables to Modules} -;;; -;;; - - -;; module-make-local-var! module symbol -;; -;; ensure a variable for V in the local namespace of M. -;; If no variable was already there, then create a new and uninitialzied -;; variable. -;; -(define (module-make-local-var! m v) - (or (let ((b (module-obarray-ref (module-obarray m) v))) - (and (variable? b) b)) - (and (module-binder m) - ((module-binder m) m v #t)) - (begin - (let ((answer (make-undefined-variable v))) - (module-obarray-set! (module-obarray m) v answer) - answer)))) - -;; module-add! module symbol var -;; -;; ensure a particular variable for V in the local namespace of M. -;; -(define (module-add! m v var) - (if (not (variable? var)) - (error "Bad variable to module-add!" var)) - (module-obarray-set! (module-obarray m) v var)) - -;; module-remove! -;; -;; make sure that a symbol is undefined in the local namespace of M. -;; -(define (module-remove! m v) - (module-obarray-remove! (module-obarray m) v)) - -(define (module-clear! m) - (vector-fill! (module-obarray m) '())) - -;; MODULE-FOR-EACH -- exported -;; -;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE). -;; -(define (module-for-each proc module) - (let ((obarray (module-obarray module))) - (do ((index 0 (+ index 1)) - (end (vector-length obarray))) - ((= index end)) - (for-each - (lambda (bucket) - (proc (car bucket) (cdr bucket))) - (vector-ref obarray index))))) - - -(define (module-map proc module) - (let* ((obarray (module-obarray module)) - (end (vector-length obarray))) - - (let loop ((i 0) - (answer '())) - (if (= i end) - answer - (loop (+ 1 i) - (append! - (map (lambda (bucket) - (proc (car bucket) (cdr bucket))) - (vector-ref obarray i)) - answer)))))) - - -;;; {Low Level Bootstrapping} -;;; - -;; make-root-module - -;; A root module uses the symhash table (the system's privileged -;; obarray). Being inside a root module is like using SCM without -;; any module system. -;; - - -(define (root-module-closure m s define?) - (let ((bi (and (symbol-interned? #f s) - (builtin-variable s)))) - (and bi - (or define? (variable-bound? bi)) - (begin - (module-add! m s bi) - bi)))) - -(define (make-root-module) - (make-module 1019 '() root-module-closure)) - - -;; make-scm-module - -;; An scm module is a module into which the lazy binder copies -;; variable bindings from the system symhash table. The mapping is -;; one way only; newly introduced bindings in an scm module are not -;; copied back into the system symhash table (and can be used to override -;; bindings from the symhash table). -;; - -(define (make-scm-module) - (make-module 1019 '() - (lambda (m s define?) - (let ((bi (and (symbol-interned? #f s) - (builtin-variable s)))) - (and bi - (variable-bound? bi) - (begin - (module-add! m s bi) - bi)))))) - - - - -;; the-module -;; -(define the-module #f) - -;; set-current-module module -;; -;; set the current module as viewed by the normalizer. -;; -(define (set-current-module m) - (set! the-module m) - (if m - (set! *top-level-lookup-closure* (module-eval-closure the-module)) - (set! *top-level-lookup-closure* #f))) - - -;; current-module -;; -;; return the current module as viewed by the normalizer. -;; -(define (current-module) the-module) - -;;; {Module-based Loading} -;;; - -(define (save-module-excursion thunk) - (let ((inner-module (current-module)) - (outer-module #f)) - (dynamic-wind (lambda () - (set! outer-module (current-module)) - (set-current-module inner-module) - (set! inner-module #f)) - thunk - (lambda () - (set! inner-module (current-module)) - (set-current-module outer-module) - (set! outer-module #f))))) - -(define basic-load load) - -(define (load-module . args) - (save-module-excursion (lambda () (apply basic-load args)))) - - - -;;; {MODULE-REF -- exported} -;; -;; Returns the value of a variable called NAME in MODULE or any of its -;; used modules. If there is no such variable, then if the optional third -;; argument DEFAULT is present, it is returned; otherwise an error is signaled. -;; -(define (module-ref module name . rest) - (let ((variable (module-variable module name))) - (if (and variable (variable-bound? variable)) - (variable-ref variable) - (if (null? rest) - (error "No variable named" name 'in module) - (car rest) ; default value - )))) - -;; MODULE-SET! -- exported -;; -;; Sets the variable called NAME in MODULE (or in a module that MODULE uses) -;; to VALUE; if there is no such variable, an error is signaled. -;; -(define (module-set! module name value) - (let ((variable (module-variable module name))) - (if variable - (variable-set! variable value) - (error "No variable named" name 'in module)))) - -;; MODULE-DEFINE! -- exported -;; -;; Sets the variable called NAME in MODULE to VALUE; if there is no such -;; variable, it is added first. -;; -(define (module-define! module name value) - (let ((variable (module-local-variable module name))) - (if variable - (variable-set! variable value) - (module-add! module name (make-variable value name))))) - -;; MODULE-USE! module interface -;; -;; Add INTERFACE to the list of interfaces used by MODULE. -;; -(define (module-use! module interface) - (set-module-uses! module - (cons interface (delq! interface (module-uses module))))) - - -;;; {Recursive Namespaces} -;;; -;;; -;;; A hierarchical namespace emerges if we consider some module to be -;;; root, and variables bound to modules as nested namespaces. -;;; -;;; The routines in this file manage variable names in hierarchical namespace. -;;; Each variable name is a list of elements, looked up in successively nested -;;; modules. -;;; -;;; (nested-ref some-root-module '(foo bar baz)) -;;; => <value of a variable named baz in the module bound to bar in -;;; the module bound to foo in some-root-module> -;;; -;;; -;;; There are: -;;; -;;; ;; a-root is a module -;;; ;; name is a list of symbols -;;; -;;; nested-ref a-root name -;;; nested-set! a-root name val -;;; nested-define! a-root name val -;;; nested-remove! a-root name -;;; -;;; -;;; (current-module) is a natural choice for a-root so for convenience there are -;;; also: -;;; -;;; local-ref name == nested-ref (current-module) name -;;; local-set! name val == nested-set! (current-module) name val -;;; local-define! name val == nested-define! (current-module) name val -;;; local-remove! name == nested-remove! (current-module) name -;;; - - -(define (nested-ref root names) - (let loop ((cur root) - (elts names)) - (cond - ((null? elts) cur) - ((not (module? cur)) #f) - (else (loop (module-ref cur (car elts) #f) (cdr elts)))))) - -(define (nested-set! root names val) - (let loop ((cur root) - (elts names)) - (if (null? (cdr elts)) - (module-set! cur (car elts) val) - (loop (module-ref cur (car elts)) (cdr elts))))) - -(define (nested-define! root names val) - (let loop ((cur root) - (elts names)) - (if (null? (cdr elts)) - (module-define! cur (car elts) val) - (loop (module-ref cur (car elts)) (cdr elts))))) - -(define (nested-remove! root names) - (let loop ((cur root) - (elts names)) - (if (null? (cdr elts)) - (module-remove! cur (car elts)) - (loop (module-ref cur (car elts)) (cdr elts))))) - -(define (local-ref names) (nested-ref (current-module) names)) -(define (local-set! names val) (nested-set! (current-module) names val)) -(define (local-define names val) (nested-define! (current-module) names val)) -(define (local-remove names) (nested-remove! (current-module) names)) - - - -;;; {#/app} -;;; -;;; The root of conventionally named objects not directly in the top level. -;;; -;;; #/app/modules -;;; #/app/modules/guile -;;; -;;; The directory of all modules and the standard root module. -;;; - -(define (module-public-interface m) (module-ref m '%module-public-interface #f)) -(define (set-module-public-interface! m i) (module-define! m '%module-public-interface i)) -(define the-root-module (make-root-module)) -(define the-scm-module (make-scm-module)) -(set-module-public-interface! the-root-module the-scm-module) -(set-module-name! the-root-module 'the-root-module) -(set-module-name! the-scm-module 'the-scm-module) - -(set-current-module the-root-module) - -(define app (make-module 31)) -(local-define '(app modules) (make-module 31)) -(local-define '(app modules guile) the-root-module) - -;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module))) - -(define (resolve-module name) - (let ((full-name (append '(app modules) name))) - (let ((already (local-ref full-name))) - (or already - (begin - (try-module-autoload name) - (make-modules-in (current-module) full-name)))))) - -(define (beautify-user-module! module) - (if (not (module-public-interface module)) - (let ((interface (make-module 31))) - (set-module-name! interface (module-name module)) - (set-module-kind! interface 'interface) - (set-module-public-interface! module interface))) - (if (not (memq the-scm-module (module-uses module))) - (set-module-uses! module (append (module-uses module) (list the-scm-module))))) - -(define (make-modules-in module name) - (if (null? name) - module - (cond - ((module-ref module (car name) #f) => (lambda (m) (make-modules-in m (cdr name)))) - (else (let ((m (make-module 31))) - (set-module-kind! m 'directory) - (set-module-name! m (car name)) - (module-define! module (car name) m) - (make-modules-in m (cdr name))))))) - -(define (resolve-interface name) - (let ((module (resolve-module name))) - (and module (module-public-interface module)))) - - -(define %autoloader-developer-mode #t) - -(define (process-define-module args) - (let* ((module-id (car args)) - (module (resolve-module module-id)) - (kws (cdr args))) - (beautify-user-module! module) - (let loop ((kws kws)) - (and (not (null? kws)) - (case (car kws) - ((:use-module) - (if (not (pair? (cdr kws))) - (error "unrecognized defmodule argument" kws)) - (let* ((used-name (cadr kws)) - (used-module (resolve-module used-name))) - (if (not (module-ref used-module '%module-public-interface #f)) - (begin - ((if %autoloader-developer-mode warn error) "no code for module" used-module) - (beautify-user-module! used-module))) - (let ((interface (module-ref used-module '%module-public-interface #f))) - (if (not interface) - (error "missing interface for use-module" used-module)) - (set-module-uses! module - (append! (delq! interface (module-uses module)) - (list interface))))) - (loop (cddr kws))) - - (else (error "unrecognized defmodule argument" kws))))) - module)) - -;;; {Autoloading modules} - -(define autoloads-in-progress '()) - -(define (try-module-autoload module-name) - - (define (sfx name) (string-append name (scheme-file-suffix))) - (let* ((reverse-name (reverse module-name)) - (name (car reverse-name)) - (dir-hint-module-name (reverse (cdr reverse-name))) - (dir-hint (apply symbol-append (map (lambda (elt) (symbol-append elt "/")) dir-hint-module-name)))) - (resolve-module dir-hint-module-name) - (and (not (autoload-done-or-in-progress? dir-hint name)) - (let ((didit #f)) - (dynamic-wind - (lambda () (autoload-in-progress! dir-hint name)) - (lambda () - (let loop ((dirs %load-path)) - (and (not (null? dirs)) - (or - (let ((d (car dirs)) - (trys (list - dir-hint - (sfx dir-hint) - (in-vicinity dir-hint name) - (in-vicinity dir-hint (sfx name))))) - (and (or-map (lambda (f) - (let ((full (in-vicinity d f))) - full - (and (file-exists? full) - (not (file-is-directory? full)) - (begin - (save-module-excursion - (lambda () - (load (string-append - d "/" f)))) - #t)))) - trys) - (begin - (set! didit #t) - #t))) - (loop (cdr dirs)))))) - (lambda () (set-autoloaded! dir-hint name didit))) - didit)))) - -(define autoloads-done '((guile . guile))) - -(define (autoload-done-or-in-progress? p m) - (let ((n (cons p m))) - (->bool (or (member n autoloads-done) - (member n autoloads-in-progress))))) - -(define (autoload-done! p m) - (let ((n (cons p m))) - (set! autoloads-in-progress - (delete! n autoloads-in-progress)) - (or (member n autoloads-done) - (set! autoloads-done (cons n autoloads-done))))) - -(define (autoload-in-progress! p m) - (let ((n (cons p m))) - (set! autoloads-done - (delete! n autoloads-done)) - (set! autoloads-in-progress (cons n autoloads-in-progress)))) - -(define (set-autoloaded! p m done?) - (if done? - (autoload-done! p m) - (let ((n (cons p m))) - (set! autoloads-done (delete! n autoloads-done)) - (set! autoloads-in-progress (delete! n autoloads-in-progress))))) - - - - - -;;; {Macros} -;;; - -(define macro-table (make-weak-key-hash-table 523)) -(define xformer-table (make-weak-key-hash-table 523)) - -(define (defmacro? m) (hashq-ref macro-table m)) -(define (assert-defmacro?! m) (hashq-set! macro-table m #t)) -(define (defmacro-transformer m) (hashq-ref xformer-table m)) -(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t)) - -(define defmacro:transformer - (lambda (f) - (let* ((xform (lambda (exp env) - (copy-tree (apply f (cdr exp))))) - (a (procedure->memoizing-macro xform))) - (assert-defmacro?! a) - (set-defmacro-transformer! a f) - a))) - - -(define defmacro - (let ((defmacro-transformer - (lambda (name parms . body) - (let ((transformer `(lambda ,parms ,@body))) - `(define ,name - (,(lambda (transformer) - (defmacro:transformer transformer)) - ,transformer)))))) - (defmacro:transformer defmacro-transformer))) - -(define defmacro:syntax-transformer - (lambda (f) - (procedure->syntax - (lambda (exp env) - (copy-tree (apply f (cdr exp))))))) - -(define (macroexpand-1 e) - (cond - ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (defined? a) (eval a)))) - (if (defmacro? val) - (apply (defmacro-transformer val) (cdr e)) - e))) - (#t e))) - -(define (macroexpand e) - (cond - ((pair? e) (let* ((a (car e)) - (val (and (symbol? a) (defined? a) (eval a)))) - (if (defmacro? val) - (macroexpand (apply (defmacro-transformer val) (cdr e))) - e))) - (#t e))) - -(define gentemp - (let ((*gensym-counter* -1)) - (lambda () - (set! *gensym-counter* (+ *gensym-counter* 1)) - (string->symbol - (string-append "scm:G" (number->string *gensym-counter*)))))) - - - - -;;; {Running Repls} -;;; - -(define (repl read evaler print) - (let loop ((source (read (current-input-port) #t read-sharp))) - (print (evaler source)) - (loop (read (current-input-port) #t read-sharp)))) - -;; A provisional repl that acts like the SCM repl: -;; -(define scm-repl-silent #f) -(define (assert-repl-silence v) (set! scm-repl-silent v)) - -(define *unspecified* (if #f #f)) -(define (unspecified? v) (eq? v *unspecified*)) - -(define scm-repl-print-unspecified #f) -(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v)) - -(define scm-repl-verbose #f) -(define (assert-repl-verbosity v) (set! scm-repl-verbose v)) - -(define scm-repl-prompt #t) -(define (assert-repl-prompt v) (set! scm-repl-prompt v)) - -(define the-prompt-string "guile> ") - -(define (error-catching-loop thunk) - (define (loop first) - (let ((next - (catch #t - (lambda () - (lazy-catch #t - (lambda () - (dynamic-wind - (lambda () (unmask-signals)) - (lambda () - (first) - - ;; This line is needed because mark doesn't do closures quite right. - ;; Unreferenced locals should be collected. - ;; - (set! first #f) - (let loop ((v (thunk))) - (loop (thunk))) - #f) - (lambda () (mask-signals)))) - - (lambda args - (save-stack 1) - (apply throw args)))) - - (lambda (key . args) - (case key - ((quit) - (force-output) - #f) - - ((switch-repl) - (apply throw 'switch-repl args)) - - ((abort) - ;; This is one of the closures that require - ;; (set! first #f) above - ;; - (lambda () - (force-output) - (display "ABORT: " (current-error-port)) - (write args (current-error-port)) - (newline (current-error-port)) - (if (and (not has-shown-debugger-hint?) - (not (memq 'backtrace (debug-options-interface))) - (stack? the-last-stack)) - (begin - (newline (current-error-port)) - (display "Type \"(backtrace)\" to get more information, -or type \"$\" to enter the debugger.\n" (current-error-port)) - (set! has-shown-debugger-hint? #t))) - (set! stack-saved? #f))) - - (else - ;; This is the other cons-leak closure... - (lambda () - (cond ((= (length args) 4) - (apply handle-system-error key args)) - (else - (apply bad-throw key args)))))))))) - (and next (loop next)))) - (loop (lambda () #t))) - -(define the-last-stack #f) -(define stack-saved? #f) - -(define (save-stack . narrowing) - (cond (stack-saved?) - ((not (memq 'debug (debug-options-interface))) - (set! the-last-stack #f) - (set! stack-saved? #t)) - (else - (set! the-last-stack - (case (stack-id #t) - ((repl-stack) - (apply make-stack #t save-stack eval narrowing)) - ((load-stack) - (apply make-stack #t save-stack gsubr-apply narrowing)) - ((tk-stack) - (apply make-stack #t save-stack tk-stack-mark narrowing)) - ((#t) - (apply make-stack #t save-stack narrowing)) - (else (let ((id (stack-id #t))) - (and (procedure? id) - (apply make-stack #t save-stack id narrowing)))))) - (set! stack-saved? #t)))) - -(define before-error-hook #f) -(define after-error-hook #f) -(define before-backtrace-hook #f) -(define after-backtrace-hook #f) - -(define has-shown-debugger-hint? #f) - -(define (handle-system-error key . args) - (let ((cep (current-error-port))) - (cond ((not (stack? the-last-stack))) - ((memq 'backtrace (debug-options-interface)) - (and before-backtrace-hook (before-backtrace-hook)) - (newline cep) - (display-backtrace the-last-stack cep) - (newline cep) - (and after-backtrace-hook (after-backtrace-hook)))) - (and before-error-hook (before-error-hook)) - (apply display-error the-last-stack cep args) - (and after-error-hook (after-error-hook)) - (force-output cep) - (throw 'abort key))) - -(define (quit . args) - (apply throw 'quit args)) - -(define has-shown-backtrace-hint? #f) - -(define (backtrace) - (if the-last-stack - (begin - (newline) - (display-backtrace the-last-stack (current-output-port)) - (newline) - (if (and (not has-shown-backtrace-hint?) - (not (memq 'backtrace (debug-options-interface)))) - (begin - (display -"Type \"(debug-enable 'backtrace)\" if you would like a backtrace -automatically if an error occurs in the future.\n") - (set! has-shown-backtrace-hint? #t)))) - (display "No backtrace available.\n"))) - -(define (error-catching-repl r e p) - (error-catching-loop (lambda () (p (e (r)))))) - -(define (gc-run-time) - (cdr (assq 'gc-time-taken (gc-stats)))) - -(define before-read-hook #f) -(define after-read-hook #f) - -(define (scm-style-repl) - (letrec ( - (start-gc-rt #f) - (start-rt #f) - (repl-report-reset (lambda () #f)) - (repl-report-start-timing (lambda () - (set! start-gc-rt (gc-run-time)) - (set! start-rt (get-internal-run-time)))) - (repl-report (lambda () - (display ";;; ") - (display (inexact->exact - (* 1000 (/ (- (get-internal-run-time) start-rt) - internal-time-units-per-second)))) - (display " msec (") - (display (inexact->exact - (* 1000 (/ (- (gc-run-time) start-gc-rt) - internal-time-units-per-second)))) - (display " msec in gc)\n"))) - (-read (lambda () - (if scm-repl-prompt - (begin - (display the-prompt-string) - (force-output) - (repl-report-reset))) - (and before-read-hook (before-read-hook)) - (let ((val (read (current-input-port) #t read-sharp))) - (and after-read-hook (after-read-hook)) - (if (eof-object? val) - (begin - (if scm-repl-verbose - (begin - (newline) - (display ";;; EOF -- quitting") - (newline))) - (quit 0))) - val))) - - (-eval (lambda (sourc) - (repl-report-start-timing) - (start-stack 'repl-stack (eval sourc)))) - - (-print (lambda (result) - (if (not scm-repl-silent) - (begin - (if (or scm-repl-print-unspecified - (not (unspecified? result))) - (begin - (write result) - (newline))) - (if scm-repl-verbose - (repl-report)) - (force-output))))) - - (-quit (lambda () - (if scm-repl-verbose - (begin - (display ";;; QUIT executed, repl exitting") - (newline) - (repl-report))) - #t)) - - (-abort (lambda () - (if scm-repl-verbose - (begin - (display ";;; ABORT executed.") - (newline) - (repl-report))) - (repl -read -eval -print)))) - - (error-catching-repl -read - -eval - -print))) - -(define (stand-alone-repl) - (let ((oport (current-input-port))) - (set-current-input-port *stdin*) - (scm-style-repl) - (set-current-input-port oport))) - - - -;;; {IOTA functions: generating lists of numbers} - -(define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '())) -(define (iota n) (list-reverse! (reverse-iota n))) - - -;;; {While} -;;; -;;; with `continue' and `break'. -;;; - -(defmacro while (cond . body) - `(letrec ((continue (lambda () (or (not ,cond) (begin (begin ,@ body) (continue))))) - (break (lambda val (apply throw 'break val)))) - (catch 'break - (lambda () (continue)) - (lambda v (cadr v))))) - - - - -;;; {Macros} -;;; - -;; actually....hobbit might be able to hack these with a little -;; coaxing -;; - -(defmacro define-macro (first . rest) - (let ((name (if (symbol? first) first (car first))) - (transformer - (if (symbol? first) - (car rest) - `(lambda ,(cdr first) ,@rest)))) - `(define ,name (defmacro:transformer ,transformer)))) - - -(defmacro define-syntax-macro (first . rest) - (let ((name (if (symbol? first) first (car first))) - (transformer - (if (symbol? first) - (car rest) - `(lambda ,(cdr first) ,@rest)))) - `(define ,name (defmacro:syntax-transformer ,transformer)))) - -;;; {Module System Macros} -;;; - -(defmacro define-module args - `(let* ((process-define-module process-define-module) - (set-current-module set-current-module) - (module (process-define-module ',args))) - (set-current-module module) - module)) - -(define define-private define) - -(defmacro define-public args - (define (syntax) - (error "bad syntax" (list 'define-public args))) - (define (defined-name n) - (cond - ((symbol? n) n) - ((pair? n) (defined-name (car n))) - (else (syntax)))) - (cond - ((null? args) (syntax)) - - (#t (let ((name (defined-name (car args)))) - `(begin - (let ((public-i (module-public-interface (current-module)))) - ;; Make sure there is a local variable: - ;; - (module-define! (current-module) - ',name - (module-ref (current-module) ',name #f)) - - ;; Make sure that local is exported: - ;; - (module-add! public-i ',name (module-variable (current-module) ',name))) - - ;; Now (re)define the var normally. - ;; - (define-private ,@ args)))))) - - - -(defmacro defmacro-public args - (define (syntax) - (error "bad syntax" (list 'defmacro-public args))) - (define (defined-name n) - (cond - ((symbol? n) n) - (else (syntax)))) - (cond - ((null? args) (syntax)) - - (#t (let ((name (defined-name (car args)))) - `(begin - (let ((public-i (module-public-interface (current-module)))) - ;; Make sure there is a local variable: - ;; - (module-define! (current-module) - ',name - (module-ref (current-module) ',name #f)) - - ;; Make sure that local is exported: - ;; - (module-add! public-i ',name (module-variable (current-module) ',name))) - - ;; Now (re)define the var normally. - ;; - (defmacro ,@ args)))))) - - - - -(define load load-module) -;(define (load . args) -; (start-stack 'load-stack (apply load-module args))) - - - -;;; {I/O functions for Tcl channels (disabled)} - -;; (define in-ch (get-standard-channel TCL_STDIN)) -;; (define out-ch (get-standard-channel TCL_STDOUT)) -;; (define err-ch (get-standard-channel TCL_STDERR)) -;; -;; (define inp (%make-channel-port in-ch "r")) -;; (define outp (%make-channel-port out-ch "w")) -;; (define errp (%make-channel-port err-ch "w")) -;; -;; (define %system-char-ready? char-ready?) -;; -;; (define (char-ready? p) -;; (if (not (channel-port? p)) -;; (%system-char-ready? p) -;; (let* ((channel (%channel-port-channel p)) -;; (old-blocking (channel-option-ref channel :blocking))) -;; (dynamic-wind -;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking "0")) -;; (lambda () (not (eof-object? (peek-char p)))) -;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking old-blocking)))))) -;; -;; (define (top-repl) -;; (with-input-from-port inp -;; (lambda () -;; (with-output-to-port outp -;; (lambda () -;; (with-error-to-port errp -;; (lambda () -;; (scm-style-repl)))))))) -;; -;; (set-current-input-port inp) -;; (set-current-output-port outp) -;; (set-current-error-port errp) - -(define (top-repl) (scm-style-repl)) - -(defmacro false-if-exception (expr) - `(catch #t (lambda () ,expr) - (lambda args #f))) - - -;;; {Calling Conventions} -(define-module (ice-9 calling)) - -;;;; -;;; -;;; This file contains a number of macros that support -;;; common calling conventions. - -;;; -;;; with-excursion-function <vars> proc -;;; <vars> is an unevaluated list of names that are bound in the caller. -;;; proc is a procedure, called: -;;; (proc excursion) -;;; -;;; excursion is a procedure isolates all changes to <vars> -;;; in the dynamic scope of the call to proc. In other words, -;;; the values of <vars> are saved when proc is entered, and when -;;; proc returns, those values are restored. Values are also restored -;;; entering and leaving the call to proc non-locally, such as using -;;; call-with-current-continuation, error, or throw. -;;; -(defmacro-public with-excursion-function (vars proc) - `(,proc ,(excursion-function-syntax vars))) - - - -;;; with-getter-and-setter <vars> proc -;;; <vars> is an unevaluated list of names that are bound in the caller. -;;; proc is a procedure, called: -;;; (proc getter setter) -;;; -;;; getter and setter are procedures used to access -;;; or modify <vars>. -;;; -;;; setter, called with keywords arguments, modifies the named -;;; values. If "foo" and "bar" are among <vars>, then: -;;; -;;; (setter :foo 1 :bar 2) -;;; == (set! foo 1 bar 2) -;;; -;;; getter, called with just keywords, returns -;;; a list of the corresponding values. For example, -;;; if "foo" and "bar" are among the <vars>, then -;;; -;;; (getter :foo :bar) -;;; => (<value-of-foo> <value-of-bar>) -;;; -;;; getter, called with no arguments, returns a list of all accepted -;;; keywords and the corresponding values. If "foo" and "bar" are -;;; the *only* <vars>, then: -;;; -;;; (getter) -;;; => (:foo <value-of-bar> :bar <value-of-foo>) -;;; -;;; The unusual calling sequence of a getter supports too handy -;;; idioms: -;;; -;;; (apply setter (getter)) ;; save and restore -;;; -;;; (apply-to-args (getter :foo :bar) ;; fetch and bind -;;; (lambda (foo bar) ....)) -;;; -;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it -;;; ;; takes its arguments in a different order. -;;; -;;; -(defmacro-public with-getter-and-setter (vars proc) - `(,proc ,@ (getter-and-setter-syntax vars))) - -;;; with-getter vars proc -;;; A short-hand for a call to with-getter-and-setter. -;;; The procedure is called: -;;; (proc getter) -;;; -(defmacro-public with-getter (vars proc) - `(,proc ,(car (getter-and-setter-syntax vars)))) - - -;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc -;;; Compose getters and setters. -;;; -;;; <vars> is an unevaluated list of names that are bound in the caller. -;;; -;;; get-delegate is called by the new getter to extend the set of -;;; gettable variables beyond just <vars> -;;; set-delegate is called by the new setter to extend the set of -;;; gettable variables beyond just <vars> -;;; -;;; proc is a procedure that is called -;;; (proc getter setter) -;;; -(defmacro-public with-delegating-getter-and-setter (vars get-delegate set-delegate proc) - `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate))) - - -;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc -;;; <vars> is an unevaluated list of names that are bound in the caller. -;;; proc is called: -;;; -;;; (proc excursion getter setter) -;;; -;;; See also: -;;; with-getter-and-setter -;;; with-excursion-function -;;; -(defmacro-public with-excursion-getter-and-setter (vars proc) - `(,proc ,(excursion-function-syntax vars) - ,@ (getter-and-setter-syntax vars))) - - -(define (excursion-function-syntax vars) - (let ((saved-value-names (map gensym vars)) - (tmp-var-name (gensym 'temp)) - (swap-fn-name (gensym 'swap)) - (thunk-name (gensym 'thunk))) - `(lambda (,thunk-name) - (letrec ((,tmp-var-name #f) - (,swap-fn-name - (lambda () ,@ (map (lambda (n sn) `(set! ,tmp-var-name ,n ,n ,sn ,sn ,tmp-var-name)) - vars saved-value-names))) - ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars)) - (dynamic-wind - ,swap-fn-name - ,thunk-name - ,swap-fn-name))))) - - -(define (getter-and-setter-syntax vars) - (let ((args-name (gensym 'args)) - (an-arg-name (gensym 'an-arg)) - (new-val-name (gensym 'new-value)) - (loop-name (gensym 'loop)) - (kws (map symbol->keyword vars))) - (list `(lambda ,args-name - (let ,loop-name ((,args-name ,args-name)) - (if (null? ,args-name) - ,(if (null? kws) - ''() - `(let ((all-vals (,loop-name ',kws))) - (let ,loop-name ((vals all-vals) - (kws ',kws)) - (if (null? vals) - '() - `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws))))))) - (map (lambda (,an-arg-name) - (case ,an-arg-name - ,@ (append - (map (lambda (kw v) `((,kw) ,v)) kws vars) - `((else (throw 'bad-get-option ,an-arg-name)))))) - ,args-name)))) - - `(lambda ,args-name - (let ,loop-name ((,args-name ,args-name)) - (or (null? ,args-name) - (null? (cdr ,args-name)) - (let ((,an-arg-name (car ,args-name)) - (,new-val-name (cadr ,args-name))) - (case ,an-arg-name - ,@ (append - (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars) - `((else (throw 'bad-set-option ,an-arg-name))))) - (,loop-name (cddr ,args-name))))))))) - -(define (delegating-getter-and-setter-syntax vars get-delegate set-delegate) - (let ((args-name (gensym 'args)) - (an-arg-name (gensym 'an-arg)) - (new-val-name (gensym 'new-value)) - (loop-name (gensym 'loop)) - (kws (map symbol->keyword vars))) - (list `(lambda ,args-name - (let ,loop-name ((,args-name ,args-name)) - (if (null? ,args-name) - (append! - ,(if (null? kws) - ''() - `(let ((all-vals (,loop-name ',kws))) - (let ,loop-name ((vals all-vals) - (kws ',kws)) - (if (null? vals) - '() - `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws))))))) - (,get-delegate)) - (map (lambda (,an-arg-name) - (case ,an-arg-name - ,@ (append - (map (lambda (kw v) `((,kw) ,v)) kws vars) - `((else (car (,get-delegate ,an-arg-name))))))) - ,args-name)))) - - `(lambda ,args-name - (let ,loop-name ((,args-name ,args-name)) - (or (null? ,args-name) - (null? (cdr ,args-name)) - (let ((,an-arg-name (car ,args-name)) - (,new-val-name (cadr ,args-name))) - (case ,an-arg-name - ,@ (append - (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars) - `((else (,set-delegate ,an-arg-name ,new-val-name))))) - (,loop-name (cddr ,args-name))))))))) - - - - -;;; with-configuration-getter-and-setter <vars-etc> proc -;;; -;;; Create a getter and setter that can trigger arbitrary computation. -;;; -;;; <vars-etc> is a list of variable specifiers, explained below. -;;; proc is called: -;;; -;;; (proc getter setter) -;;; -;;; Each element of the <vars-etc> list is of the form: -;;; -;;; (<var> getter-hook setter-hook) -;;; -;;; Both hook elements are evaluated; the variable name is not. -;;; Either hook may be #f or procedure. -;;; -;;; A getter hook is a thunk that returns a value for the corresponding -;;; variable. If omitted (#f is passed), the binding of <var> is -;;; returned. -;;; -;;; A setter hook is a procedure of one argument that accepts a new value -;;; for the corresponding variable. If omitted, the binding of <var> -;;; is simply set using set!. -;;; -(defmacro-public with-configuration-getter-and-setter (vars-etc proc) - `((lambda (simpler-get simpler-set body-proc) - (with-delegating-getter-and-setter () - simpler-get simpler-set body-proc)) - - (lambda (kw) - (case kw - ,@(map (lambda (v) `((,(symbol->keyword (car v))) - ,(cond - ((cadr v) => list) - (else `(list ,(car v)))))) - vars-etc))) - - (lambda (kw new-val) - (case kw - ,@(map (lambda (v) `((,(symbol->keyword (car v))) - ,(cond - ((caddr v) => (lambda (proc) `(,proc new-val))) - (else `(set! ,(car v) new-val))))) - vars-etc))) - - ,proc)) - -(defmacro-public with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc) - `((lambda (simpler-get simpler-set body-proc) - (with-delegating-getter-and-setter () - simpler-get simpler-set body-proc)) - - (lambda (kw) - (case kw - ,@(append! (map (lambda (v) `((,(symbol->keyword (car v))) - ,(cond - ((cadr v) => list) - (else `(list ,(car v)))))) - vars-etc) - `((else (,delegate-get kw)))))) - - (lambda (kw new-val) - (case kw - ,@(append! (map (lambda (v) `((,(symbol->keyword (car v))) - ,(cond - ((caddr v) => (lambda (proc) `(,proc new-val))) - (else `(set! ,(car v) new-val))))) - vars-etc) - `((else (,delegate-set kw new-val)))))) - - ,proc)) - - -;;; let-configuration-getter-and-setter <vars-etc> proc -;;; -;;; This procedure is like with-configuration-getter-and-setter (q.v.) -;;; except that each element of <vars-etc> is: -;;; -;;; (<var> initial-value getter-hook setter-hook) -;;; -;;; Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter -;;; introduces bindings for the variables named in <vars-etc>. -;;; It is short-hand for: -;;; -;;; (let ((<var1> initial-value-1) -;;; (<var2> initial-value-2) -;;; ...) -;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc)) -;;; -(defmacro-public let-with-configuration-getter-and-setter (vars-etc proc) - `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc) - (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc) - ,proc))) - - - - -;;; {Implementation of COMMON LISP list functions for Scheme} - -(define-module (ice-9 common-list)) - -;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme -; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer. -; -;Permission to copy this software, to redistribute it, and to use it -;for any purpose is granted, subject to the following restrictions and -;understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;;;From: hugh@ear.mit.edu (Hugh Secker-Walker) -(define-public (make-list k . init) - (set! init (if (pair? init) (car init))) - (do ((k k (+ -1 k)) - (result '() (cons init result))) - ((<= k 0) result))) - -(define-public (adjoin e l) (if (memq e l) l (cons e l))) - -(define-public (union l1 l2) - (cond ((null? l1) l2) - ((null? l2) l1) - (else (union (cdr l1) (adjoin (car l1) l2))))) - -(define-public (intersection l1 l2) - (cond ((null? l1) l1) - ((null? l2) l2) - ((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2))) - (else (intersection (cdr l1) l2)))) - -(define-public (set-difference l1 l2) - (cond ((null? l1) l1) - ((memv (car l1) l2) (set-difference (cdr l1) l2)) - (else (cons (car l1) (set-difference (cdr l1) l2))))) - -(define-public (reduce-init p init l) - (if (null? l) - init - (reduce-init p (p init (car l)) (cdr l)))) - -(define-public (reduce p l) - (cond ((null? l) l) - ((null? (cdr l)) (car l)) - (else (reduce-init p (car l) (cdr l))))) - -(define-public (some pred l . rest) - (cond ((null? rest) - (let mapf ((l l)) - (and (not (null? l)) - (or (pred (car l)) (mapf (cdr l)))))) - (else (let mapf ((l l) (rest rest)) - (and (not (null? l)) - (or (apply pred (car l) (map car rest)) - (mapf (cdr l) (map cdr rest)))))))) - -(define-public (every pred l . rest) - (cond ((null? rest) - (let mapf ((l l)) - (or (null? l) - (and (pred (car l)) (mapf (cdr l)))))) - (else (let mapf ((l l) (rest rest)) - (or (null? l) - (and (apply pred (car l) (map car rest)) - (mapf (cdr l) (map cdr rest)))))))) - -(define-public (notany pred . ls) (not (apply some pred ls))) - -(define-public (notevery pred . ls) (not (apply every pred ls))) - -(define-public (find-if t l) - (cond ((null? l) #f) - ((t (car l)) (car l)) - (else (find-if t (cdr l))))) - -(define-public (member-if t l) - (cond ((null? l) #f) - ((t (car l)) l) - (else (member-if t (cdr l))))) - -(define-public (remove-if p l) - (cond ((null? l) '()) - ((p (car l)) (remove-if p (cdr l))) - (else (cons (car l) (remove-if p (cdr l)))))) - -(define-public (delete-if! pred list) - (let delete-if ((list list)) - (cond ((null? list) '()) - ((pred (car list)) (delete-if (cdr list))) - (else - (set-cdr! list (delete-if (cdr list))) - list)))) - -(define-public (delete-if-not! pred list) - (let delete-if ((list list)) - (cond ((null? list) '()) - ((not (pred (car list))) (delete-if (cdr list))) - (else - (set-cdr! list (delete-if (cdr list))) - list)))) - -(define-public (butlast lst n) - (letrec ((l (- (length lst) n)) - (bl (lambda (lst n) - (cond ((null? lst) lst) - ((positive? n) - (cons (car lst) (bl (cdr lst) (+ -1 n)))) - (else '()))))) - (bl lst (if (negative? n) - (slib:error "negative argument to butlast" n) - l)))) - -(define-public (and? . args) - (cond ((null? args) #t) - ((car args) (apply and? (cdr args))) - (else #f))) - -(define-public (or? . args) - (cond ((null? args) #f) - ((car args) #t) - (else (apply or? (cdr args))))) - -(define-public (has-duplicates? lst) - (cond ((null? lst) #f) - ((member (car lst) (cdr lst)) #t) - (else (has-duplicates? (cdr lst))))) - -(define-public (list* x . y) - (define (list*1 x) - (if (null? (cdr x)) - (car x) - (cons (car x) (list*1 (cdr x))))) - (if (null? y) - x - (cons x (list*1 y)))) - -;; pick p l -;; Apply P to each element of L, returning a list of elts -;; for which P returns a non-#f value. -;; -(define-public (pick p l) - (let loop ((s '()) - (l l)) - (cond - ((null? l) s) - ((p (car l)) (loop (cons (car l) s) (cdr l))) - (else (loop s (cdr l)))))) - -;; pick p l -;; Apply P to each element of L, returning a list of the -;; non-#f return values of P. -;; -(define-public (pick-mappings p l) - (let loop ((s '()) - (l l)) - (cond - ((null? l) s) - ((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l)))) - (else (loop s (cdr l)))))) - -(define-public (uniq l) - (if (null? l) - '() - (let ((u (uniq (cdr l)))) - (if (memq (car l) u) - u - (cons (car l) u))))) - - -;;; {Functions for browsing modules} - -(define-module (ice-9 ls) - :use-module (ice-9 common-list)) - -;;;; -;;; local-definitions-in root name -;;; Returns a list of names defined locally in the named -;;; subdirectory of root. -;;; definitions-in root name -;;; Returns a list of all names defined in the named -;;; subdirectory of root. The list includes alll locally -;;; defined names as well as all names inherited from a -;;; member of a use-list. -;;; -;;; A convenient interface for examining the nature of things: -;;; -;;; ls . various-names -;;; -;;; With just one argument, interpret that argument as the -;;; name of a subdirectory of the current module and -;;; return a list of names defined there. -;;; -;;; With more than one argument, still compute -;;; subdirectory lists, but return a list: -;;; ((<subdir-name> . <names-defined-there>) -;;; (<subdir-name> . <names-defined-there>) -;;; ...) -;;; - -(define-public (local-definitions-in root names) - (let ((m (nested-ref root names)) - (answer '())) - (if (not (module? m)) - (set! answer m) - (module-for-each (lambda (k v) (set! answer (cons k answer))) m)) - answer)) - -(define-public (definitions-in root names) - (let ((m (nested-ref root names))) - (if (not (module? m)) - m - (reduce union - (cons (local-definitions-in m '()) - (map (lambda (m2) (definitions-in m2 '())) - (module-uses m))))))) - -(define-public (ls . various-refs) - (and various-refs - (if (cdr various-refs) - (map (lambda (ref) - (cons ref (definitions-in (current-module) ref))) - various-refs) - (definitions-in (current-module) (car various-refs))))) - -(define-public (lls . various-refs) - (and various-refs - (if (cdr various-refs) - (map (lambda (ref) - (cons ref (local-definitions-in (current-module) ref))) - various-refs) - (local-definitions-in (current-module) (car various-refs))))) - -(define-public (recursive-local-define name value) - (let ((parent (reverse! (cdr (reverse name))))) - (and parent (make-modules-in (current-module) parent)) - (local-define name value))) - -;;; {Queues} - -(define-module (ice-9 q)) - -;;;; Copyright (C) 1995 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; - -;;;; -;;; Q: Based on the interface to -;;; -;;; "queue.scm" Queues/Stacks for Scheme -;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. -;;; - -;;;; -;;; {Q} -;;; -;;; A list is just a bunch of cons pairs that follows some constrains, right? -;;; Association lists are the same. Hash tables are just vectors and association -;;; lists. You can print them, read them, write them as constants, pun them off as other data -;;; structures etc. This is good. This is lisp. These structures are fast and compact -;;; and easy to manipulate arbitrarily because of their simple, regular structure and -;;; non-disjointedness (associations being lists and so forth). -;;; -;;; So I figured, queues should be the same -- just a "subtype" of cons-pair -;;; structures in general. -;;; -;;; A queue is a cons pair: -;;; ( <the-q> . <last-pair> ) -;;; -;;; <the-q> is a list of things in the q. New elements go at the end of that list. -;;; -;;; <last-pair> is #f if the q is empty, and otherwise is the last pair of <the-q>. -;;; -;;; q's print nicely, but alas, they do not read well because the eq?-ness of -;;; <last-pair> and (last-pair <the-q>) is lost by read. The procedure -;;; -;;; (sync-q! q) -;;; -;;; recomputes and resets the <last-pair> component of a queue. -;;; - -(define-public (sync-q! obj) (set-cdr! obj (and (car obj) (last-pair (car obj))))) - -;;; make-q -;;; return a new q. -;;; -(define-public (make-q) (cons '() '())) - -;;; q? obj -;;; Return true if obj is a Q. -;;; An object is a queue if it is equal? to '(#f . #f) or -;;; if it is a pair P with (list? (car P)) and (eq? (cdr P) (last-pair P)). -;;; -(define-public (q? obj) (and (pair? obj) - (or (and (null? (car obj)) - (null? (cdr obj))) - (and - (list? (car obj)) - (eq? (cdr obj) (last-pair (car obj))))))) - -;;; q-empty? obj -;;; -(define-public (q-empty? obj) (null? (car obj))) - -;;; q-empty-check q -;;; Throw a q-empty exception if Q is empty. -(define-public (q-empty-check q) (if (q-empty? q) (throw 'q-empty q))) - - -;;; q-front q -;;; Return the first element of Q. -(define-public (q-front q) (q-empty-check q) (caar q)) - -;;; q-front q -;;; Return the last element of Q. -(define-public (q-rear q) (q-empty-check q) (cadr q)) - -;;; q-remove! q obj -;;; Remove all occurences of obj from Q. -(define-public (q-remove! q obj) - (while (memq obj (car q)) - (set-car! q (delq! obj (car q)))) - (set-cdr! q (last-pair (car q)))) - -;;; q-push! q obj -;;; Add obj to the front of Q -(define-public (q-push! q d) - (let ((h (cons d (car q)))) - (set-car! q h) - (if (null? (cdr q)) - (set-cdr! q h)))) - -;;; enq! q obj -;;; Add obj to the rear of Q -(define-public (enq! q d) - (let ((h (cons d '()))) - (if (not (null? (cdr q))) - (set-cdr! (cdr q) h) - (set-car! q h)) - (set-cdr! q h))) - -;;; q-pop! q -;;; Take the front of Q and return it. -(define-public (q-pop! q) - (q-empty-check q) - (let ((it (caar q)) - (next (cdar q))) - (if (not next) - (set-cdr! q #f)) - (set-car! q next) - it)) - -;;; deq! q -;;; Take the front of Q and return it. -(define-public deq! q-pop!) - -;;; q-length q -;;; Return the number of enqueued elements. -;;; -(define-public (q-length q) (length (car q))) - - - - -;;; {The runq data structure} - -(define-module (ice-9 runq) - :use-module (ice-9 q)) - -;;;; Copyright (C) 1996 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; - -;;;; -;;; -;;; One way to schedule parallel computations in a serial environment is -;;; to explicitly divide each task up into small, finite execution time, -;;; strips. Then you interleave the execution of strips from various -;;; tasks to achieve a kind of parallelism. Runqs are a handy data -;;; structure for this style of programming. -;;; -;;; We use thunks (nullary procedures) and lists of thunks to represent -;;; strips. By convention, the return value of a strip-thunk must either -;;; be another strip or the value #f. -;;; -;;; A runq is a procedure that manages a queue of strips. Called with no -;;; arguments, it processes one strip from the queue. Called with -;;; arguments, the arguments form a control message for the queue. The -;;; first argument is a symbol which is the message selector. -;;; -;;; A strip is processed this way: If the strip is a thunk, the thunk is -;;; called -- if it returns a strip, that strip is added back to the -;;; queue. To process a strip which is a list of thunks, the CAR of that -;;; list is called. After a call to that CAR, there are 0, 1, or 2 strips -;;; -- perhaps one returned by the thunk, and perhaps the CDR of the -;;; original strip if that CDR is not nil. The runq puts whichever of -;;; these strips exist back on the queue. (The exact order in which -;;; strips are put back on the queue determines the scheduling behavior of -;;; a particular queue -- it's a parameter.) -;;; -;;; - - - -;;;; -;;; (runq-control q msg . args) -;;; -;;; processes in the default way the control messages that -;;; can be sent to a runq. Q should be an ordinary -;;; Q (see utils/q.scm). -;;; -;;; The standard runq messages are: -;;; -;;; 'add! strip0 strip1... ;; to enqueue one or more strips -;;; 'enqueue! strip0 strip1... ;; to enqueue one or more strips -;;; 'push! strip0 ... ;; add strips to the front of the queue -;;; 'empty? ;; true if it is -;;; 'length ;; how many strips in the queue? -;;; 'kill! ;; empty the queue -;;; else ;; throw 'not-understood -;;; -(define-public (runq-control q msg . args) - (case msg - ((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*) - ((enque!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*) - ((push!) (for-each (lambda (t) (q-push! q t)) args) '*unspecified*) - ((empty?) (q-empty? q)) - ((length) (q-length q)) - ((kill!) (set! q (make-q))) - (else (throw 'not-understood msg args)))) - -(define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f))) - -;;;; -;;; make-void-runq -;;; -;;; Make a runq that discards all messages except "length", for which -;;; it returns 0. -;;; -(define-public (make-void-runq) - (lambda opts - (and opts - (apply-to-args opts - (lambda (msg . args) - (case msg - ((length) 0) - (else #f))))))) - -;;;; -;;; (make-fair-runq) -;;; -;;; Returns a runq procedure. -;;; Called with no arguments, the procedure processes one strip from the queue. -;;; Called with arguments, it uses runq-control. -;;; -;;; In a fair runq, if a strip returns a new strip X, X is added -;;; to the end of the queue, meaning it will be the last to execute -;;; of all the remaining procedures. -;;; -(define-public (make-fair-runq) - (letrec ((q (make-q)) - (self - (lambda ctl - (if ctl - (apply runq-control q ctl) - (and (not (q-empty? q)) - (let ((next-strip (deq! q))) - (cond - ((procedure? next-strip) (let ((k (run-strip next-strip))) - (and k (enq! q k)))) - ((pair? next-strip) (let ((k (run-strip (car next-strip)))) - (and k (enq! q k))) - (if (not (null? (cdr next-strip))) - (enq! q (cdr next-strip))))) - self)))))) - self)) - - -;;;; -;;; (make-exclusive-runq) -;;; -;;; Returns a runq procedure. -;;; Called with no arguments, the procedure processes one strip from the queue. -;;; Called with arguments, it uses runq-control. -;;; -;;; In an exclusive runq, if a strip W returns a new strip X, X is added -;;; to the front of the queue, meaning it will be the next to execute -;;; of all the remaining procedures. -;;; -;;; An exception to this occurs if W was the CAR of a list of strips. -;;; In that case, after the return value of W is pushed onto the front -;;; of the queue, the CDR of the list of strips is pushed in front -;;; of that (if the CDR is not nil). This way, the rest of the thunks -;;; in the list that contained W have priority over the return value of W. -;;; -(define-public (make-exclusive-runq) - (letrec ((q (make-q)) - (self - (lambda ctl - (if ctl - (apply runq-control q ctl) - (and (not (q-empty? q)) - (let ((next-strip (deq! q))) - (cond - ((procedure? next-strip) (let ((k (run-strip next-strip))) - (and k (q-push! q k)))) - ((pair? next-strip) (let ((k (run-strip (car next-strip)))) - (and k (q-push! q k))) - (if (not (null? (cdr next-strip))) - (q-push! q (cdr next-strip))))) - self)))))) - self)) - - -;;;; -;;; (make-subordinate-runq-to superior basic-inferior) -;;; -;;; Returns a runq proxy for the runq basic-inferior. -;;; -;;; The proxy watches for operations on the basic-inferior that cause -;;; a transition from a queue length of 0 to a non-zero length and -;;; vice versa. While the basic-inferior queue is not empty, -;;; the proxy installs a task on the superior runq. Each strip -;;; of that task processes N strips from the basic-inferior where -;;; N is the length of the basic-inferior queue when the proxy -;;; strip is entered. [Countless scheduling variations are possible.] -;;; -(define-public (make-subordinate-runq-to superior-runq basic-runq) - (let ((runq-task (cons #f #f))) - (set-car! runq-task - (lambda () - (if (basic-runq 'empty?) - (set-cdr! runq-task #f) - (do ((n (basic-runq 'length) (1- n))) - ((<= n 0) #f) - (basic-runq))))) - (letrec ((self - (lambda ctl - (if (not ctl) - (let ((answer (basic-runq))) - (self 'empty?) - answer) - (begin - (case (car ctl) - ((suspend) (set-cdr! runq-task #f)) - (else (let ((answer (apply basic-runq ctl))) - (if (and (not (cdr runq-task)) (not (basic-runq 'empty?))) - (begin - (set-cdr! runq-task runq-task) - (superior-runq 'add! runq-task))) - answer)))))))) - self))) - -;;;; -;;; (define fork-strips (lambda args args)) -;;; Return a strip that starts several strips in -;;; parallel. If this strip is enqueued on a fair -;;; runq, strips of the parallel subtasks will run -;;; round-robin style. -;;; -(define fork-strips (lambda args args)) - - -;;;; -;;; (strip-sequence . strips) -;;; -;;; Returns a new strip which is the concatenation of the argument strips. -;;; -(define-public ((strip-sequence . strips)) - (let loop ((st (let ((a strips)) (set! strips #f) a))) - (and (not (null? st)) - (let ((then ((car st)))) - (if then - (lambda () (loop (cons then (cdr st)))) - (lambda () (loop (cdr st)))))))) - - -;;;; -;;; (fair-strip-subtask . initial-strips) -;;; -;;; Returns a new strip which is the synchronos, fair, -;;; parallel execution of the argument strips. -;;; -;;; -;;; -(define-public (fair-strip-subtask . initial-strips) - (let ((st (make-fair-runq))) - (apply st 'add! initial-strips) - st)) - - -;;; {String Fun} - -(define-module (ice-9 string-fun)) - -;;;; -;;; -;;; Various string funcitons, particularly those that take -;;; advantage of the "shared substring" capability. -;;; - -;;; {String Fun: Dividing Strings Into Fields} -;;; -;;; The names of these functions are very regular. -;;; Here is a grammar of a call to one of these: -;;; -;;; <string-function-invocation> -;;; := (<action>-<seperator-disposition>-<seperator-determination> <seperator-param> <str> <ret>) -;;; -;;; <str> = the string -;;; -;;; <ret> = The continuation. String functions generally return -;;; multiple values by passing them to this procedure. -;;; -;;; <action> = split -;;; | separate-fields -;;; -;;; "split" means to divide a string into two parts. -;;; <ret> will be called with two arguments. -;;; -;;; "separate-fields" means to divide a string into as many -;;; parts as possible. <ret> will be called with -;;; however many fields are found. -;;; -;;; <seperator-disposition> = before -;;; | after -;;; | discarding -;;; -;;; "before" means to leave the seperator attached to -;;; the beginning of the field to its right. -;;; "after" means to leave the seperator attached to -;;; the end of the field to its left. -;;; "discarding" means to discard seperators. -;;; -;;; Other dispositions might be handy. For example, "isolate" -;;; could mean to treat the separator as a field unto itself. -;;; -;;; <seperator-determination> = char -;;; | predicate -;;; -;;; "char" means to use a particular character as field seperator. -;;; "predicate" means to check each character using a particular predicate. -;;; -;;; Other determinations might be handy. For example, "character-set-member". -;;; -;;; <seperator-param> = A parameter that completes the meaning of the determinations. -;;; For example, if the determination is "char", then this parameter -;;; says which character. If it is "predicate", the parameter is the -;;; predicate. -;;; -;;; -;;; For example: -;;; -;;; (separate-fields-discarding-char #\, "foo, bar, baz, , bat" list) -;;; => ("foo" " bar" " baz" " " " bat") -;;; -;;; (split-after-char #\- 'an-example-of-split list) -;;; => ("an-" "example-of-split") -;;; -;;; As an alternative to using a determination "predicate", or to trying to do anything -;;; complicated with these functions, consider using regular expressions. -;;; - -(define-public (split-after-char char str ret) - (let ((end (cond - ((string-index str char) => 1+) - (else (string-length str))))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) - -(define-public (split-before-char char str ret) - (let ((end (or (string-index str char) - (string-length str)))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) - -(define-public (split-discarding-char char str ret) - (let ((end (string-index str char))) - (if (not end) - (ret str "") - (ret (make-shared-substring str 0 end) - (make-shared-substring str (1+ end)))))) - -(define-public (split-after-char-last char str ret) - (let ((end (cond - ((string-rindex str char) => 1+) - (else 0)))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) - -(define-public (split-before-char-last char str ret) - (let ((end (or (string-rindex str char) 0))) - (ret (make-shared-substring str 0 end) - (make-shared-substring str end)))) - -(define-public (split-discarding-char-last char str ret) - (let ((end (string-rindex str char))) - (if (not end) - (ret str "") - (ret (make-shared-substring str 0 end) - (make-shared-substring str (1+ end)))))) - -(define (split-before-predicate pred str ret) - (let loop ((n 0)) - (cond - ((= n (length str)) (ret str "")) - ((not (pred (string-ref str n))) (loop (1+ n))) - (else (ret (make-shared-substring str 0 n) - (make-shared-substring str n)))))) -(define (split-after-predicate pred str ret) - (let loop ((n 0)) - (cond - ((= n (length str)) (ret str "")) - ((not (pred (string-ref str n))) (loop (1+ n))) - (else (ret (make-shared-substring str 0 (1+ n)) - (make-shared-substring str (1+ n))))))) - -(define (split-discarding-predicate pred str ret) - (let loop ((n 0)) - (cond - ((= n (length str)) (ret str "")) - ((not (pred (string-ref str n))) (loop (1+ n))) - (else (ret (make-shared-substring str 0 n) - (make-shared-substring str (1+ n))))))) - -(define-public (separate-fields-discarding-char ch str ret) - (let loop ((fields '()) - (str str)) - (cond - ((string-rindex str ch) - => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields) - (make-shared-substring str 0 w)))) - (else (ret (cons str fields)))))) - -(define-public (separate-fields-after-char ch str ret) - (let loop ((fields '()) - (str str)) - (cond - ((string-rindex str ch) - => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields) - (make-shared-substring str 0 (+ 1 w))))) - (else (ret (cons str fields)))))) - -(define-public (separate-fields-before-char ch str ret) - (let loop ((fields '()) - (str str)) - (cond - ((string-rindex str ch) - => (lambda (pos) (loop (cons (make-shared-substring str w) fields) - (make-shared-substring str 0 w)))) - (else (ret (cons str fields)))))) - - -;;; {String Fun: String Prefix Predicates} -;;; -;;; Very simple: -;;; -;;; (define-public ((string-prefix-predicate pred?) prefix str) -;;; (and (<= (length prefix) (length str)) -;;; (pred? prefix (make-shared-substring str 0 (length prefix))))) -;;; -;;; (define-public string-prefix=? (string-prefix-predicate string=?)) -;;; - -(define-public ((string-prefix-predicate pred?) prefix str) - (and (<= (length prefix) (length str)) - (pred? prefix (make-shared-substring str 0 (length prefix))))) - -(define-public string-prefix=? (string-prefix-predicate string=?)) - - -;;; {String Fun: Strippers} -;;; -;;; <stripper> = sans-<removable-part> -;;; -;;; <removable-part> = surrounding-whitespace -;;; | trailing-whitespace -;;; | leading-whitespace -;;; | final-newline -;;; - -(define-public (sans-surrounding-whitespace s) - (let ((st 0) - (end (string-length s))) - (while (and (< st (string-length s)) - (char-whitespace? (string-ref s st))) - (set! st (1+ st))) - (while (and (< 0 end) - (char-whitespace? (string-ref s (1- end)))) - (set! end (1- end))) - (if (< end st) - "" - (make-shared-substring s st end)))) - -(define-public (sans-trailing-whitespace s) - (let ((st 0) - (end (string-length s))) - (while (and (< 0 end) - (char-whitespace? (string-ref s (1- end)))) - (set! end (1- end))) - (if (< end st) - "" - (make-shared-substring s st end)))) - -(define-public (sans-leading-whitespace s) - (let ((st 0) - (end (string-length s))) - (while (and (< st (string-length s)) - (char-whitespace? (string-ref s st))) - (set! st (1+ st))) - (if (< end st) - "" - (make-shared-substring s st end)))) - -(define-public (sans-final-newline str) - (cond - ((= 0 (string-length str)) - str) - - ((char=? #\nl (string-ref str (1- (string-length str)))) - (make-shared-substring str 0 (1- (string-length str)))) - - (else str))) - -;;; {String Fun: has-trailing-newline?} -;;; - -(define-public (has-trailing-newline? str) - (and (< 0 (string-length str)) - (char=? #\nl (string-ref str (1- (string-length str)))))) - - - -;;; {String Fun: with-regexp-parts} - -(define-public (with-regexp-parts regexp fields str return fail) - (let ((parts (regexec regexp str fields))) - (if (number? parts) - (fail parts) - (apply return parts)))) - - -;;; {Load debug extension code if debug extensions present.} -;;; -;;; *fixme* This is a temporary solution. -;;; - -(if (memq 'debug-extensions *features*) - (define-module (guile) :use-module (ice-9 debug))) - - -;;; {Load thread code if threads are present.} -;;; -;;; *fixme* This is a temporary solution. -;;; - -(if (memq 'threads *features*) - (define-module (guile) :use-module (ice-9 threads))) - - -;;; {Load emacs interface support if emacs option is given.} -;;; -;;; *fixme* This is a temporary solution. -;;; - -(if (or (member "-e" (cdr (program-arguments))) - (member "--emacs" (cdr (program-arguments)))) - (define-module (guile) :use-module (ice-9 emacs))) - - - -(define-module (guile)) - -(append! %load-path (cons "." ())) diff --git a/ice-9/configure b/ice-9/configure deleted file mode 100755 index 4676147d1..000000000 --- a/ice-9/configure +++ /dev/null @@ -1,961 +0,0 @@ -#! /bin/sh - -# Guess values for system-dependent variables and create Makefiles. -# Generated automatically using autoconf version 2.12 -# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - -# Defaults: -ac_help= -ac_default_prefix=/usr/local -# Any additions from configure.in: - -# Initialize some variables set by options. -# The variables have the same names as the options, with -# dashes changed to underlines. -build=NONE -cache_file=./config.cache -exec_prefix=NONE -host=NONE -no_create= -nonopt=NONE -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -target=NONE -verbose= -x_includes=NONE -x_libraries=NONE -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datadir='${prefix}/share' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -libdir='${exec_prefix}/lib' -includedir='${prefix}/include' -oldincludedir='/usr/include' -infodir='${prefix}/info' -mandir='${prefix}/man' - -# Initialize some other variables. -subdirs= -MFLAGS= MAKEFLAGS= -# Maximum number of lines to put in a shell here document. -ac_max_here_lines=12 - -ac_prev= -for ac_option -do - - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval "$ac_prev=\$ac_option" - ac_prev= - continue - fi - - case "$ac_option" in - -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; - *) ac_optarg= ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case "$ac_option" in - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir="$ac_optarg" ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build="$ac_optarg" ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file="$ac_optarg" ;; - - -datadir | --datadir | --datadi | --datad | --data | --dat | --da) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ - | --da=*) - datadir="$ac_optarg" ;; - - -disable-* | --disable-*) - ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - eval "enable_${ac_feature}=no" ;; - - -enable-* | --enable-*) - ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "enable_${ac_feature}='$ac_optarg'" ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix="$ac_optarg" ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he) - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat << EOF -Usage: configure [options] [host] -Options: [defaults in brackets after descriptions] -Configuration: - --cache-file=FILE cache test results in FILE - --help print this message - --no-create do not create output files - --quiet, --silent do not print \`checking...' messages - --version print the version of autoconf that created configure -Directory and file names: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [same as prefix] - --bindir=DIR user executables in DIR [EPREFIX/bin] - --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] - --libexecdir=DIR program executables in DIR [EPREFIX/libexec] - --datadir=DIR read-only architecture-independent data in DIR - [PREFIX/share] - --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data in DIR - [PREFIX/com] - --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] - --libdir=DIR object code libraries in DIR [EPREFIX/lib] - --includedir=DIR C header files in DIR [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] - --infodir=DIR info documentation in DIR [PREFIX/info] - --mandir=DIR man documentation in DIR [PREFIX/man] - --srcdir=DIR find the sources in DIR [configure dir or ..] - --program-prefix=PREFIX prepend PREFIX to installed program names - --program-suffix=SUFFIX append SUFFIX to installed program names - --program-transform-name=PROGRAM - run sed PROGRAM on installed program names -EOF - cat << EOF -Host type: - --build=BUILD configure for building on BUILD [BUILD=HOST] - --host=HOST configure for HOST [guessed] - --target=TARGET configure for TARGET [TARGET=HOST] -Features and packages: - --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) - --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --x-includes=DIR X include files are in DIR - --x-libraries=DIR X library files are in DIR -EOF - if test -n "$ac_help"; then - echo "--enable and --with options recognized:$ac_help" - fi - exit 0 ;; - - -host | --host | --hos | --ho) - ac_prev=host ;; - -host=* | --host=* | --hos=* | --ho=*) - host="$ac_optarg" ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir="$ac_optarg" ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir="$ac_optarg" ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir="$ac_optarg" ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir="$ac_optarg" ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst \ - | --locals | --local | --loca | --loc | --lo) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* \ - | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) - localstatedir="$ac_optarg" ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir="$ac_optarg" ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir="$ac_optarg" ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix="$ac_optarg" ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix="$ac_optarg" ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix="$ac_optarg" ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name="$ac_optarg" ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir="$ac_optarg" ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir="$ac_optarg" ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site="$ac_optarg" ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir="$ac_optarg" ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir="$ac_optarg" ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target="$ac_optarg" ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers) - echo "configure generated by autoconf version 2.12" - exit 0 ;; - - -with-* | --with-*) - ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "with_${ac_package}='$ac_optarg'" ;; - - -without-* | --without-*) - ac_package=`echo $ac_option|sed -e 's/-*without-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - eval "with_${ac_package}=no" ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes="$ac_optarg" ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries="$ac_optarg" ;; - - -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } - ;; - - *) - if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then - echo "configure: warning: $ac_option: invalid host type" 1>&2 - fi - if test "x$nonopt" != xNONE; then - { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } - fi - nonopt="$ac_option" - ;; - - esac -done - -if test -n "$ac_prev"; then - { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } -fi - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -# File descriptor usage: -# 0 standard input -# 1 file creation -# 2 errors and warnings -# 3 some systems may open it to /dev/tty -# 4 used on the Kubota Titan -# 6 checking for... messages and results -# 5 compiler messages saved in config.log -if test "$silent" = yes; then - exec 6>/dev/null -else - exec 6>&1 -fi -exec 5>./config.log - -echo "\ -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. -" 1>&5 - -# Strip out --no-create and --no-recursion so they do not pile up. -# Also quote any args containing shell metacharacters. -ac_configure_args= -for ac_arg -do - case "$ac_arg" in - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) ;; - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; - *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) - ac_configure_args="$ac_configure_args '$ac_arg'" ;; - *) ac_configure_args="$ac_configure_args $ac_arg" ;; - esac -done - -# NLS nuisances. -# Only set these to C if already set. These must not be set unconditionally -# because not all systems understand e.g. LANG=C (notably SCO). -# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! -# Non-C LC_CTYPE values break the ctype check. -if test "${LANG+set}" = set; then LANG=C; export LANG; fi -if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi -if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi -if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -rf conftest* confdefs.h -# AIX cpp loses on an empty file, so make sure it contains at least a newline. -echo > confdefs.h - -# A filename unique to this package, relative to the directory that -# configure is in, which we can look for to find out if srcdir is correct. -ac_unique_file=boot-9.scm - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then its parent. - ac_prog=$0 - ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` - test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. - srcdir=$ac_confdir - if test ! -r $srcdir/$ac_unique_file; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r $srcdir/$ac_unique_file; then - if test "$ac_srcdir_defaulted" = yes; then - { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } - else - { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } - fi -fi -srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` - -# Prefer explicitly selected file to automatically selected ones. -if test -z "$CONFIG_SITE"; then - if test "x$prefix" != xNONE; then - CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" - else - CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" - fi -fi -for ac_site_file in $CONFIG_SITE; do - if test -r "$ac_site_file"; then - echo "loading site script $ac_site_file" - . "$ac_site_file" - fi -done - -if test -r "$cache_file"; then - echo "loading cache $cache_file" - . $cache_file -else - echo "creating cache $cache_file" - > $cache_file -fi - -ac_ext=c -# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. -ac_cpp='$CPP $CPPFLAGS' -ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' -ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' -cross_compiling=$ac_cv_prog_cc_cross - -if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then - # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. - if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then - ac_n= ac_c=' -' ac_t=' ' - else - ac_n=-n ac_c= ac_t= - fi -else - ac_n= ac_c='\c' ac_t= -fi - - -ac_aux_dir= -for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do - if test -f $ac_dir/install-sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f $ac_dir/install.sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - fi -done -if test -z "$ac_aux_dir"; then - { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } -fi -ac_config_guess=$ac_aux_dir/config.guess -ac_config_sub=$ac_aux_dir/config.sub -ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. - -# Find a good install program. We prefer a C program (faster), -# so one script is as good as another. But avoid the broken or -# incompatible versions: -# SysV /etc/install, /usr/sbin/install -# SunOS /usr/etc/install -# IRIX /sbin/install -# AIX /bin/install -# AFS /usr/afsws/bin/install, which mishandles nonexistent args -# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" -# ./install, which can be erroneously created by make from ./install.sh. -echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:552: checking for a BSD compatible install" >&5 -if test -z "$INSTALL"; then -if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - # Account for people who put trailing slashes in PATH elements. - case "$ac_dir/" in - /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; - *) - # OSF1 and SCO ODT 3.0 have their own names for install. - for ac_prog in ginstall installbsd scoinst install; do - if test -f $ac_dir/$ac_prog; then - if test $ac_prog = install && - grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then - # AIX install. It has an incompatible calling convention. - # OSF/1 installbsd also uses dspmsg, but is usable. - : - else - ac_cv_path_install="$ac_dir/$ac_prog -c" - break 2 - fi - fi - done - ;; - esac - done - IFS="$ac_save_IFS" - -fi - if test "${ac_cv_path_install+set}" = set; then - INSTALL="$ac_cv_path_install" - else - # As a last resort, use the slow shell script. We don't cache a - # path for INSTALL within a source directory, because that will - # break other packages using the cache if that directory is - # removed, or if the path is relative. - INSTALL="$ac_install_sh" - fi -fi -echo "$ac_t""$INSTALL" 1>&6 - -# Use test -z because SunOS4 sh mishandles braces in ${var-val}. -# It thinks the first close brace ends the variable substitution. -test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' - -test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' - - -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' - - -. $srcdir/../GUILE-VERSION - -PACKAGE=$PACKAGE - -cat >> confdefs.h <<EOF -#define PACKAGE "$PACKAGE" -EOF - -VERSION=$VERSION - -cat >> confdefs.h <<EOF -#define VERSION "$VERSION" -EOF - -echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6 -echo "configure:620: checking whether build environment is sane" >&5 -echo timestamp > conftestfile -# Do this in a subshell so we don't clobber the current shell's -# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? -if (set X `ls -t $srcdir/configure conftestfile`; test "$2" = conftestfile) -then - # Ok. - : -else - { echo "configure: error: newly created file is older than distributed files! -Check your system clock" 1>&2; exit 1; } -fi -rm -f conftest* -echo "$ac_t""yes" 1>&6 -if test "$program_transform_name" = s,x,x,; then - program_transform_name= -else - # Double any \ or $. echo might interpret backslashes. - cat <<\EOF_SED > conftestsed -s,\\,\\\\,g; s,\$,$$,g -EOF_SED - program_transform_name="`echo $program_transform_name|sed -f conftestsed`" - rm -f conftestsed -fi -test "$program_prefix" != NONE && - program_transform_name="s,^,${program_prefix},; $program_transform_name" -# Use a double $ so make ignores it. -test "$program_suffix" != NONE && - program_transform_name="s,\$\$,${program_suffix},; $program_transform_name" - -# sed with no file args requires a program. -test "$program_transform_name" = "" && program_transform_name="s,x,x," - -echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 -echo "configure:654: checking whether ${MAKE-make} sets \${MAKE}" >&5 -set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftestmake <<\EOF -all: - @echo 'ac_maketemp="${MAKE}"' -EOF -# GNU make sometimes prints "make[1]: Entering...", which would confuse us. -eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=` -if test -n "$ac_maketemp"; then - eval ac_cv_prog_make_${ac_make}_set=yes -else - eval ac_cv_prog_make_${ac_make}_set=no -fi -rm -f conftestmake -fi -if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then - echo "$ac_t""yes" 1>&6 - SET_MAKE= -else - echo "$ac_t""no" 1>&6 - SET_MAKE="MAKE=${MAKE-make}" -fi - -ac_aux_dir= -for ac_dir in .. $srcdir/..; do - if test -f $ac_dir/install-sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f $ac_dir/install.sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - fi -done -if test -z "$ac_aux_dir"; then - { echo "configure: error: can not find install-sh or install.sh in .. $srcdir/.." 1>&2; exit 1; } -fi -ac_config_guess=$ac_aux_dir/config.guess -ac_config_sub=$ac_aux_dir/config.sub -ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. - -module=ice-9 - -trap '' 1 2 15 -cat > confcache <<\EOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs. It is not useful on other systems. -# If it contains results you don't want to keep, you may remove or edit it. -# -# By default, configure uses ./config.cache as the cache file, -# creating it if it does not exist already. You can give configure -# the --cache-file=FILE option to use a different cache file; that is -# what configure does when it calls configure scripts in -# subdirectories, so they share the cache. -# Giving --cache-file=/dev/null disables caching, for debugging configure. -# config.status only pays attention to the cache file if you give it the -# --recheck option to rerun configure. -# -EOF -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, don't put newlines in cache variables' values. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -(set) 2>&1 | - case `(ac_space=' '; set) 2>&1` in - *ac_space=\ *) - # `set' does not quote correctly, so add quotes (double-quote substitution - # turns \\\\ into \\, and sed turns \\ into \). - sed -n \ - -e "s/'/'\\\\''/g" \ - -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" - ;; - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' - ;; - esac >> confcache -if cmp -s $cache_file confcache; then - : -else - if test -w $cache_file; then - echo "updating cache $cache_file" - cat confcache > $cache_file - else - echo "not updating unwritable cache $cache_file" - fi -fi -rm -f confcache - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -# Any assignment to VPATH causes Sun make to only execute -# the first set of double-colon rules, so remove it if not needed. -# If there is a colon in the path, we need to keep it. -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' -fi - -trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 - -# Transform confdefs.h into DEFS. -# Protect against shell expansion while executing Makefile rules. -# Protect against Makefile macro expansion. -cat > conftest.defs <<\EOF -s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g -s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g -s%\[%\\&%g -s%\]%\\&%g -s%\$%$$%g -EOF -DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` -rm -f conftest.defs - - -# Without the "./", some shells look in PATH for config.status. -: ${CONFIG_STATUS=./config.status} - -echo creating $CONFIG_STATUS -rm -f $CONFIG_STATUS -cat > $CONFIG_STATUS <<EOF -#! /bin/sh -# Generated automatically by configure. -# Run this file to recreate the current configuration. -# This directory was configured as follows, -# on host `(hostname || uname -n) 2>/dev/null | sed 1q`: -# -# $0 $ac_configure_args -# -# Compiler output produced by configure, useful for debugging -# configure, is in ./config.log if it exists. - -ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" -for ac_option -do - case "\$ac_option" in - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" - exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; - -version | --version | --versio | --versi | --vers | --ver | --ve | --v) - echo "$CONFIG_STATUS generated by autoconf version 2.12" - exit 0 ;; - -help | --help | --hel | --he | --h) - echo "\$ac_cs_usage"; exit 0 ;; - *) echo "\$ac_cs_usage"; exit 1 ;; - esac -done - -ac_given_srcdir=$srcdir -ac_given_INSTALL="$INSTALL" - -trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 -EOF -cat >> $CONFIG_STATUS <<EOF - -# Protect against being on the right side of a sed subst in config.status. -sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g; - s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF -$ac_vpsub -$extrasub -s%@CFLAGS@%$CFLAGS%g -s%@CPPFLAGS@%$CPPFLAGS%g -s%@CXXFLAGS@%$CXXFLAGS%g -s%@DEFS@%$DEFS%g -s%@LDFLAGS@%$LDFLAGS%g -s%@LIBS@%$LIBS%g -s%@exec_prefix@%$exec_prefix%g -s%@prefix@%$prefix%g -s%@program_transform_name@%$program_transform_name%g -s%@bindir@%$bindir%g -s%@sbindir@%$sbindir%g -s%@libexecdir@%$libexecdir%g -s%@datadir@%$datadir%g -s%@sysconfdir@%$sysconfdir%g -s%@sharedstatedir@%$sharedstatedir%g -s%@localstatedir@%$localstatedir%g -s%@libdir@%$libdir%g -s%@includedir@%$includedir%g -s%@oldincludedir@%$oldincludedir%g -s%@infodir@%$infodir%g -s%@mandir@%$mandir%g -s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g -s%@INSTALL_DATA@%$INSTALL_DATA%g -s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g -s%@PACKAGE@%$PACKAGE%g -s%@VERSION@%$VERSION%g -s%@SET_MAKE@%$SET_MAKE%g -s%@module@%$module%g - -CEOF -EOF - -cat >> $CONFIG_STATUS <<\EOF - -# Split the substitutions into bite-sized pieces for seds with -# small command number limits, like on Digital OSF/1 and HP-UX. -ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. -ac_file=1 # Number of current file. -ac_beg=1 # First line for current file. -ac_end=$ac_max_sed_cmds # Line after last line for current file. -ac_more_lines=: -ac_sed_cmds="" -while $ac_more_lines; do - if test $ac_beg -gt 1; then - sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file - else - sed "${ac_end}q" conftest.subs > conftest.s$ac_file - fi - if test ! -s conftest.s$ac_file; then - ac_more_lines=false - rm -f conftest.s$ac_file - else - if test -z "$ac_sed_cmds"; then - ac_sed_cmds="sed -f conftest.s$ac_file" - else - ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" - fi - ac_file=`expr $ac_file + 1` - ac_beg=$ac_end - ac_end=`expr $ac_end + $ac_max_sed_cmds` - fi -done -if test -z "$ac_sed_cmds"; then - ac_sed_cmds=cat -fi -EOF - -cat >> $CONFIG_STATUS <<EOF - -CONFIG_FILES=\${CONFIG_FILES-"Makefile"} -EOF -cat >> $CONFIG_STATUS <<\EOF -for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case "$ac_file" in - *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` - ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; - *) ac_file_in="${ac_file}.in" ;; - esac - - # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. - - # Remove last slash and all that follows it. Not all systems have dirname. - ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` - if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then - # The file is in a subdirectory. - test ! -d "$ac_dir" && mkdir "$ac_dir" - ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" - # A "../" for each directory in $ac_dir_suffix. - ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` - else - ac_dir_suffix= ac_dots= - fi - - case "$ac_given_srcdir" in - .) srcdir=. - if test -z "$ac_dots"; then top_srcdir=. - else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; - /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; - *) # Relative path. - srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" - top_srcdir="$ac_dots$ac_given_srcdir" ;; - esac - - case "$ac_given_INSTALL" in - [/$]*) INSTALL="$ac_given_INSTALL" ;; - *) INSTALL="$ac_dots$ac_given_INSTALL" ;; - esac - - echo creating "$ac_file" - rm -f "$ac_file" - configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." - case "$ac_file" in - *Makefile*) ac_comsub="1i\\ -# $configure_input" ;; - *) ac_comsub= ;; - esac - - ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` - sed -e "$ac_comsub -s%@configure_input@%$configure_input%g -s%@srcdir@%$srcdir%g -s%@top_srcdir@%$top_srcdir%g -s%@INSTALL@%$INSTALL%g -" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file -fi; done -rm -f conftest.s* - -EOF -cat >> $CONFIG_STATUS <<EOF - -EOF -cat >> $CONFIG_STATUS <<\EOF - -exit 0 -EOF -chmod +x $CONFIG_STATUS -rm -fr confdefs* $ac_clean_files -test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 - diff --git a/ice-9/configure.in b/ice-9/configure.in deleted file mode 100644 index b2d4c334b..000000000 --- a/ice-9/configure.in +++ /dev/null @@ -1,7 +0,0 @@ -# -# Process this file with autoconf to produce a configure script. -# - -AC_INIT(boot-9.scm) -AM_INIT_GUILE_MODULE(ice-9) -AC_OUTPUT(Makefile) diff --git a/ice-9/debug.scm b/ice-9/debug.scm deleted file mode 100644 index 20e67f9cf..000000000 --- a/ice-9/debug.scm +++ /dev/null @@ -1,120 +0,0 @@ -;;;; Copyright (C) 1996 Mikael Djurfeldt -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; -;;;; The author can be reached at djurfeldt@nada.kth.se -;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN -;;;; - - -(define-module #/ice-9/debug) - - - -;;; {Run-time options} - -(define names '((debug-options-interface - (debug-options debug-enable debug-disable) - (debug-set!)) - - (evaluator-traps-interface - (traps trap-enable trap-disable) - (trap-set!)) - - (read-options-interface - (read-options read-enable read-disable) - (read-set!)) - - (print-options-interface - (print-options print-enable print-disable) - (print-set!)) - )) - -(define option-name car) -(define option-value cadr) -(define option-documentation caddr) - -(define (print-option option) - (display (option-name option)) - (if (< (string-length (symbol->string (option-name option))) 8) - (display #\tab)) - (display #\tab) - (display (option-value option)) - (display #\tab) - (display (option-documentation option)) - (newline)) - -;;; Below follows the macros defining the run-time option interfaces. -;;; *fixme* These should not be macros, but need to be until module -;;; system is improved. -;;; - -(define (make-options interface) - `(lambda args - (cond ((null? args) (,interface)) - ((pair? (car args)) (,interface (car args)) (,interface)) - (else (for-each print-option (,interface #t)))))) - -(define (make-enable interface) - `(lambda flags - (,interface (append flags (,interface))) - (,interface))) - -(define (make-disable interface) - `(lambda flags - (let ((options (,interface))) - (for-each (lambda (flag) - (set! options (delq! flag options))) - flags) - (,interface options) - (,interface)))) - -(define (make-set! interface) - `((name exp) - (,'quasiquote - (begin (,interface (append (,interface) - (list '(,'unquote name) - (,'unquote exp)))) - (,interface))))) - -(defmacro define-all () - (cons 'begin - (apply append - (map (lambda (group) - (let ((interface (car group))) - (append (map (lambda (name constructor) - `(define-public ,name - ,(constructor interface))) - (cadr group) - (list make-options - make-enable - make-disable)) - (map (lambda (name constructor) - `(defmacro-public ,name - ,@(constructor interface))) - (caddr group) - (list make-set!))))) - names)))) - -(define-all) - - - -;;; A fix to get the error handling working together with the module system. -;;; -(variable-set! (builtin-variable 'debug-options) debug-options) - -(debug-enable 'debug) -(read-enable 'positions) diff --git a/ice-9/expect.scm b/ice-9/expect.scm deleted file mode 100644 index 6d25c8ba3..000000000 --- a/ice-9/expect.scm +++ /dev/null @@ -1,125 +0,0 @@ -;;; installed-scm-file - -;;;; Copyright (C) 1996 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; - - -;;; Expect: a macro for selecting actions based on what it reads from a port. -;;; The idea is from Don Libes' expect based on Tcl. -;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer. - - -(define expect-port #f) -(define expect-timeout #f) -(define expect-timeout-proc #f) -(define expect-eof-proc #f) -(define expect-char-proc #f) - -;;; expect: each test is a procedure which is applied to the accumulating -;;; string. -(defmacro expect clauses - (let ((s (gentemp)) - (c (gentemp)) - (port (gentemp)) - (timeout (gentemp))) - `(let ((,s "") - (,port (or expect-port (current-input-port))) - (,timeout (if expect-timeout - (+ (* expect-timeout internal-time-units-per-second) - (get-internal-real-time)) - #f))) - (let next-char () - (if (and expect-timeout - (or (>= (get-internal-real-time) ,timeout) - (and (not (char-ready? ,port)) - (not (expect-select ,port ,timeout))))) - (if expect-timeout-proc - (expect-timeout-proc ,s) - #f) - (let ((,c (read-char ,port))) - (if expect-char-proc - (expect-char-proc ,c)) - (cond ((eof-object? ,c) - (if expect-eof-proc - (expect-eof-proc ,s) - #f)) - (else - (set! ,s (string-append ,s (string ,c))) - (cond - ,@(let next-expr ((tests (map car clauses)) - (exprs (map cdr clauses)) - (body ())) - (cond - ((null? tests) - (reverse body)) - (else - (next-expr - (cdr tests) - (cdr exprs) - (cons - `((,(car tests) ,s) - ,@(cond ((null? (car exprs)) - ()) - ((eq? (caar exprs) '=>) - (if (not (= (length (car exprs)) - 2)) - (scm-error 'misc-error - "expect" - "bad recipient: %S" - (list (car exprs)) - #f) - `((apply ,(cadar exprs) - (,(car tests) ,s))))) - (else - (car exprs)))) - body))))) - (else (next-char))))))))))) - -;;; the regexec front-end to expect: -;;; each test must evaluate to a regular expression. -(defmacro expect-strings clauses - `(let ,@(let next-test ((tests (map car clauses)) - (exprs (map cdr clauses)) - (defs ()) - (body ())) - (cond ((null? tests) - (list (reverse defs) `(expect ,@(reverse body)))) - (else - (let ((rxname (gentemp))) - (next-test (cdr tests) - (cdr exprs) - (cons `(,rxname (regcomp ,(car tests) - REG_NEWLINE)) - defs) - (cons `((lambda (s) - (regexec ,rxname s "")) - ,@(car exprs)) - body)))))))) - -;;; simplified select: returns #t if input is waiting or #f if timed out. -;;; timeout is absolute in terms of get-internal-real-time. -(define (expect-select port timeout) - (let* ((relative (- timeout (get-internal-real-time))) - (relative-s (inexact->exact - (floor (/ relative internal-time-units-per-second)))) - (relative-ms (inexact->exact - (round (/ (* (- relative relative-s) 1000) - internal-time-units-per-second))))) - (and (> relative 0) - (pair? (car (select (list port) () () - relative-s - relative-ms)))))) diff --git a/ice-9/hcons.scm b/ice-9/hcons.scm deleted file mode 100644 index febd5e8c7..000000000 --- a/ice-9/hcons.scm +++ /dev/null @@ -1,76 +0,0 @@ -;;; installed-scm-file - -;;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; - - -(define-module #/ice-9/hcons) - - -;;; {Eq? hash-consing} -;;; -;;; A hash conser maintains a private universe of pairs s.t. if -;;; two cons calls pass eq? arguments, the pairs returned are eq?. -;;; -;;; A hash conser does not contribute life to the pairs it returns. -;;; - -(define-public (hashq-cons-hash pair n) - (modulo (logxor (hashq (car pair) 4194303) - (hashq (cdr pair) 4194303)) - n)) - -(define-public (hashq-cons-assoc key l) - (and l (or (and (pair? l) - (pair? (car l)) - (pair? (caar l)) - (eq? (car key) (caaar l)) - (eq? (cdr key) (cdaar l)) - (car l)) - (hashq-cons-assoc key (cdr l))))) - -(define-public (hashq-cons-get-handle table key) - (hashx-get-handle hashq-cons-hash hashq-cons-assoc table key #f)) - -(define-public (hashq-cons-create-handle! table key init) - (hashx-create-handle! hashq-cons-hash hashq-cons-assoc table key init)) - -(define-public (hashq-cons-ref table key) - (hashx-ref hashq-cons-hash hashq-cons-assoc table key #f)) - -(define-public (hashq-cons-set! table key val) - (hashx-set! hashq-cons-hash hashq-cons-assoc table key val)) - -(define-public (hashq-cons table a d) - (car (hashq-cons-create-handle! table (cons a d) #f))) - -(define-public (hashq-conser hash-tab-or-size) - (let ((table (if (vector? hash-tab-or-size) - hash-tab-or-size - (make-doubly-weak-hash-table hash-tab-or-size)))) - (lambda (a d) (hashq-cons table a d)))) - - - - -(define-public (make-gc-buffer n) - (let ((ring (make-list n #f))) - (append! ring ring) - (lambda (next) - (set-car! ring next) - (set! ring (cdr ring)) - next))) diff --git a/ice-9/lineio.scm b/ice-9/lineio.scm deleted file mode 100644 index ffde88608..000000000 --- a/ice-9/lineio.scm +++ /dev/null @@ -1,112 +0,0 @@ -;;; installed-scm-file - -;;;; Copyright (C) 1996 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; - - - -(define-module #/ice-9/lineio) - - -;;; {Line Buffering Input Ports} -;;; -;;; [This is a work-around to get past certain deficiencies in the capabilities -;;; of ports. Eventually, ports should be fixed and this module nuked.] -;;; -;;; A line buffering input port supports: -;;; -;;; read-string which returns the next line of input -;;; unread-string which pushes a line back onto the stream -;;; -;;; Normally a "line" is all characters up to and including a newline. -;;; If lines are put back using unread-string, they can be broken arbitrarily -;;; -- that is, read-string returns strings passed to unread-string (or -;;; shared substrings of them). -;;; - -;; read-string port -;; unread-string port str -;; Read (or buffer) a line from PORT. -;; -;; Not all ports support these functions -- only those with -;; 'unread-string and 'read-string properties, bound to hooks -;; implementing these functions. -;; -(define-public (unread-string str line-buffering-input-port) - ((object-property line-buffering-input-port 'unread-string) str)) - -;; -(define-public (read-string line-buffering-input-port) - ((object-property line-buffering-input-port 'read-string))) - - -(define-public (lineio-port? port) - (not (not (object-property port 'read-string)))) - -;; make-line-buffering-input-port port -;; Return a wrapper for PORT. The wrapper handles read-string/unread-string. -;; -;; The port returned by this function reads newline terminated lines from PORT. -;; It buffers these characters internally, and parsels them out via calls -;; to read-char, read-string, and unread-string. -;; - -(define-public (make-line-buffering-input-port underlying-port) - (let* (;; buffers - a list of strings put back by unread-string or cached - ;; using read-line. - ;; - (buffers '()) - - ;; getc - return the next character from a buffer or from the underlying - ;; port. - ;; - (getc (lambda () - (if (not buffers) - (read-char underlying-port) - (let ((c (string-ref (car buffers)))) - (if (= 1 (string-length (car buffers))) - (set! buffers (cdr buffers)) - (set-car! buffers (make-shared-substring (car buffers) 1))) - c)))) - - (propogate-close (lambda () (close-port underlying-port))) - - (self (make-soft-port (vector #f #f #f getc propogate-close) "r")) - - (unread-string (lambda (str) - (and (< 0 (string-length str)) - (if (ungetc-char-ready? self) - (set! buffers (append! (list str (string (read-char self))) buffers)) - (set! buffers (cons str buffers)))))) - - (read-string (lambda () - (cond - (buffers (let ((answer (car buffers))) - (set! buffers (cdr buffers)) - answer)) - - ((ungetc-char-ready? self) (read-line self 'include-newline)) - - (else (read-line underlying-port 'include-newline))))) - - ) - - (set-object-property! self 'unread-string unread-string) - (set-object-property! self 'read-string read-string) - self)) - - diff --git a/ice-9/mapping.scm b/ice-9/mapping.scm deleted file mode 100644 index ceb3a1b38..000000000 --- a/ice-9/mapping.scm +++ /dev/null @@ -1,121 +0,0 @@ -;;; installed-scm-file - -;;;; Copyright (C) 1996 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; - - - -(define-module #/ice-9/mapping - :use-module #/ice-9/poe) - -(define-public mapping-hooks-type (make-record-type 'mapping-hooks '(get-handle - create-handle - remove))) - - -(define-public make-mapping-hooks (perfect-funcq 17 (record-constructor mapping-hooks-type))) -(define-public mapping-hooks? (record-predicate mapping-hooks-type)) -(define-public mapping-hooks-get-handle (record-accessor mapping-hooks-type 'get-handle)) -(define-public mapping-hooks-create-handle (record-accessor mapping-hooks-type 'create-handle)) -(define-public mapping-hooks-remove (record-accessor mapping-hooks-type 'remove)) - -(define-public mapping-type (make-record-type 'mapping '(hooks data))) -(define-public make-mapping (record-constructor mapping-type)) -(define-public mapping? (record-predicate mapping-type)) -(define-public mapping-hooks (record-accessor mapping-type 'hooks)) -(define-public mapping-data (record-accessor mapping-type 'data)) -(define-public set-mapping-hooks! (record-modifier mapping-type 'hooks)) -(define-public set-mapping-data! (record-modifier mapping-type 'data)) - -(define-public (mapping-get-handle map key) - ((mapping-hooks-get-handle (mapping-hooks map)) map key)) -(define-public (mapping-create-handle! map key . opts) - (apply (mapping-hooks-create-handle (mapping-hooks map)) map key opts)) -(define-public (mapping-remove! map key) - ((mapping-hooks-remove (mapping-hooks map)) map key)) - -(define-public (mapping-ref map key . dflt) - (cond - ((mapping-get-handle map key) => cdr) - (dflt => car) - (else #f))) - -(define-public (mapping-set! map key val) - (set-cdr! (mapping-create-handle! map key #f) val)) - - - -(define-public hash-table-mapping-hooks - (let ((wrap (lambda (proc) (lambda (1st . rest) (apply proc (mapping-data 1st) rest))))) - - (perfect-funcq 17 - (lambda (hash-proc assoc-proc delete-proc) - (let ((procs (list hash-proc assoc-proc delete-proc))) - (cond - ((equal? procs `(,hashq ,assq ,delq!)) - (make-mapping-hooks (wrap hashq-get-handle) - (wrap hashq-create-handle!) - (wrap hashq-remove!))) - ((equal? procs `(,hashv ,assv ,delv!)) - (make-mapping-hooks (wrap hashv-get-handle) - (wrap hashv-create-handle!) - (wrap hashv-remove!))) - ((equal? procs `(,hash ,assoc ,delete!)) - (make-mapping-hooks (wrap hash-get-handle) - (wrap hash-create-handle!) - (wrap hash-remove!))) - (else - (make-mapping-hooks (wrap - (lambda (table key) - (hashx-get-handle hash-proc assoc-proc table key))) - (wrap - (lambda (table key) - (hashx-create-handle hash-proc assoc-proc table key))) - (wrap - (lambda (table key) - (hashx-get-handle hash-proc assoc-proc delete-proc table key))))))))))) - -(define-public (make-hash-table-mapping table hash-proc assoc-proc delete-proc) - (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc delete-proc) table)) - -(define-public (hash-table-mapping . options) - (let* ((size (or (and options (number? (car options)) (car options)) - 71)) - (hash-proc (or (kw-arg-ref options :hash-proc) hash)) - (assoc-proc (or (kw-arg-ref options :assoc-proc) - (cond - ((eq? hash-proc hash) assoc) - ((eq? hash-proc hashv) assv) - ((eq? hash-proc hashq) assq) - (else (error 'hash-table-mapping - "Hash-procedure specified with no known assoc function." - hash-proc))))) - (delete-proc (or (kw-arg-ref options :delete-proc) - (cond - ((eq? hash-proc hash) delete!) - ((eq? hash-proc hashv) delv!) - ((eq? hash-proc hashq) delq!) - (else (error 'hash-table-mapping - "Hash-procedure specified with no known delete function." - hash-proc))))) - (table-constructor (or (kw-arg-ref options :table-constructor) - (lambda (len) (make-vector len '()))))) - (make-hash-table-mapping (table-constructor size) - hash-proc - assoc-proc - delete-proc))) - diff --git a/ice-9/poe.scm b/ice-9/poe.scm deleted file mode 100644 index eb3a13fca..000000000 --- a/ice-9/poe.scm +++ /dev/null @@ -1,117 +0,0 @@ -;;; installed-scm-file - -;;;; Copyright (C) 1996 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; - - -(define-module #/ice-9/poe - :use-module #/ice-9/hcons) - - - - -;;; {Pure Functions} -;;; -;;; A pure function (of some sort) is characterized by two equality -;;; relations: one on argument lists and one on return values. -;;; A pure function is one that when applied to equal arguments lists -;;; yields equal results. -;;; -;;; If the equality relationship on return values can be eq?, it may make -;;; sense to cache values returned by the function. Choosing the right -;;; equality relation on arguments is tricky. -;;; - - -;;; {pure-funcq} -;;; -;;; The simplest case of pure functions are those in which results -;;; are only certainly eq? if all of the arguments are. These functions -;;; are called "pure-funcq", for obvious reasons. -;;; - - -(define funcq-memo (make-weak-key-hash-table 523)) ; !!! randomly selected values -(define funcq-buffer (make-gc-buffer 256)) - -(define (funcq-hash arg-list n) - (let ((it (let loop ((x 0) - (arg-list arg-list)) - (if (null? arg-list) - (modulo x n) - (loop (logior x (hashq (car arg-list) 4194303)) - (cdr arg-list)))))) - it)) - -(define (funcq-assoc arg-list alist) - (let ((it (and alist - (let and-map ((key arg-list) - (entry (caar alist))) - (or (and (and (not key) (not entry)) - (car alist)) - (and key entry - (eq? (car key) (car entry)) - (and-map (cdr key) (cdr entry)))))))) - it)) - - - -(define-public (pure-funcq base-func) - (lambda args - (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args)))) - (if cached - (begin - (funcq-buffer (car cached)) - (cdr cached)) - - (let ((val (apply base-func args)) - (key (cons base-func args))) - (funcq-buffer key) - (hashx-set! funcq-hash funcq-assoc funcq-memo key val) - val))))) - - - -;;; {Perfect funq} -;;; -;;; A pure funq may sometimes forget its past but a perfect -;;; funcq never does. -;;; - -(define-public (perfect-funcq size base-func) - (define funcq-memo (make-hash-table size)) - - (lambda args - (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args)))) - (if cached - (begin - (funcq-buffer (car cached)) - (cdr cached)) - - (let ((val (apply base-func args)) - (key (cons base-func args))) - (funcq-buffer key) - (hashx-set! funcq-hash funcq-assoc funcq-memo key val) - val))))) - - - - - - - - diff --git a/ice-9/r4rs.scm b/ice-9/r4rs.scm deleted file mode 100644 index 696ba4059..000000000 --- a/ice-9/r4rs.scm +++ /dev/null @@ -1,149 +0,0 @@ -;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant -;;;; Jim Blandy <jimb@cyclic.com> --- October 1996 - -;;;; Copyright (C) 1996 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;;; apply and call-with-current-continuation - -;;; These turn syntax, @apply and @call-with-current-continuation, -;;; into procedures. If someone knows why they have to be syntax to -;;; begin with, please fix this comment. -(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args)))) -(define (call-with-current-continuation proc) - (@call-with-current-continuation proc)) - - -;;;; Basic Port Code - -;;; Specifically, the parts of the low-level port code that are written in -;;; Scheme rather than C. -;;; -;;; WARNING: the parts of this interface that refer to file ports -;;; are going away. It would be gone already except that it is used -;;; "internally" in a few places. - - -;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper -;; mode to open files in. MSDOS does carraige return - newline -;; translation if not opened in `b' mode. -;; -(define OPEN_READ (case (software-type) - ((MS-DOS WINDOWS ATARIST) "rb") - (else "r"))) -(define OPEN_WRITE (case (software-type) - ((MS-DOS WINDOWS ATARIST) "wb") - (else "w"))) -(define OPEN_BOTH (case (software-type) - ((MS-DOS WINDOWS ATARIST) "r+b") - (else "r+"))) - -(define *null-device* "/dev/null") - -(define (open-input-file str) - (open-file str OPEN_READ)) - -(define (open-output-file str) - (open-file str OPEN_WRITE)) - -(define (open-io-file str) (open-file str OPEN_BOTH)) -(define close-input-port close-port) -(define close-output-port close-port) -(define close-io-port close-port) - -(define (call-with-input-file str proc) - (let* ((file (open-input-file str)) - (ans (proc file))) - (close-input-port file) - ans)) - -(define (call-with-output-file str proc) - (let* ((file (open-output-file str)) - (ans (proc file))) - (close-output-port file) - ans)) - -(define (with-input-from-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-input-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-output-to-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-output-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-error-to-port port thunk) - (let* ((swaports (lambda () (set! port (set-current-error-port port))))) - (dynamic-wind swaports thunk swaports))) - -(define (with-input-from-file file thunk) - (let* ((nport (open-input-file file)) - (ans (with-input-from-port nport thunk))) - (close-port nport) - ans)) - -(define (with-output-to-file file thunk) - (let* ((nport (open-output-file file)) - (ans (with-output-to-port nport thunk))) - (close-port nport) - ans)) - -(define (with-error-to-file file thunk) - (let* ((nport (open-output-file file)) - (ans (with-error-to-port nport thunk))) - (close-port nport) - ans)) - -(define (with-input-from-string string thunk) - (call-with-input-string string - (lambda (p) (with-input-from-port p thunk)))) - -(define (with-output-to-string thunk) - (call-with-output-string - (lambda (p) (with-output-to-port p thunk)))) - -(define (with-error-to-string thunk) - (call-with-output-string - (lambda (p) (with-error-to-port p thunk)))) - -(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p)))) - - -;;;; Loading - -(if (not (defined? '%load-verbosely)) - (define %load-verbosely #f)) -(define (assert-load-verbosity v) (set! %load-verbosely v)) - -(define (%load-announce file) - (if %load-verbosely - (with-output-to-port (current-error-port) - (lambda () - (display ";;; ") - (display "loading ") - (display file) - (newline) - (force-output))))) - -(set! %load-hook %load-announce) - -;;; If we load boot-9.scm, it provides a definition for this which is -;;; more sophisticated. -(define read-sharp #f) - -(define (load name) - (start-stack 'load-stack - (primitive-load name #t read-sharp))) diff --git a/ice-9/slib.scm b/ice-9/slib.scm deleted file mode 100644 index 0e717db71..000000000 --- a/ice-9/slib.scm +++ /dev/null @@ -1,188 +0,0 @@ -;;; installed-scm-file -(define-module #/ice-9/slib) - - - -(define (eval-load <filename> evl) - (if (not (file-exists? <filename>)) - (set! <filename> (string-append <filename> (scheme-file-suffix)))) - (call-with-input-file <filename> - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* <filename>) - (do ((o (read port #t read-sharp) (read port #t read-sharp))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - - - -(define slib:exit quit) -(define slib:error error) -(define slib:eval eval) -(define defmacro:eval eval) -(define logical:logand logand) -(define logical:logior logior) -(define logical:logxor logxor) -(define logical:lognot lognot) -(define logical:ash ash) -(define logical:logcount logcount) -(define logical:integer-length integer-length) -(define logical:bit-extract bit-extract) -(define logical:integer-expt integer-expt) -(define logical:ipow-by-squaring ipow-by-squaring) -(define slib:eval-load eval-load) -(define slib:tab #\tab) -(define slib:form-feed #\page) - -(define slib:features - (append '(source - eval - abort - alist - defmacro - delay - dynamic-wind - full-continuation - hash - hash-table - line-i/o - logical - multiarg/and- - multiarg-apply - promise - rev2-procedures - rev4-optional-procedures - string-port - with-file) - - (if (defined? 'getenv) - '(getenv) - '()) - - (if (defined? 'current-time) - '(current-time) - '()) - - (if (defined? 'system) - '(system) - '()) - - (if (defined? 'array?) - '(array) - '()) - - (if (defined? 'char-ready?) - '(char-ready?) - '()) - - (if (defined? 'array-for-each) - '(array-for-each) - '()) - - (if (and (string->number "0.0") (inexact? (string->number "0.0"))) - '(inexact) - '()) - - (if (rational? (string->number "1/19")) - '(rational) - '()) - - (if (real? (string->number "0.0")) - '(real) - ()) - - (if (complex? (string->number "1+i")) - '(complex) - '()) - - (let ((n (string->number "9999999999999999999999999999999"))) - (if (and n (exact? n)) - '(bignum) - '())))) - - -(define slib-module (current-module)) - -(define (slib:load name) - (save-module-excursion - (lambda () - (set-current-module slib-module) - (let* ((errinfo (catch 'system-error - (lambda () - (basic-load name) - #f) - (lambda args args))) - (errinfo (and errinfo - (catch 'system-error - (lambda () - (basic-load (string-append name ".scm")) - #f) - (lambda args args))))) - (if errinfo - (apply throw errinfo)))))) - -(define slib:load-source slib:load) -(define defmacro:load slib:load) - -(define slib-parent-dir - (let* ((path (%search-load-path "slib/require.scm"))) - (if path - (make-shared-substring path 0 (- (string-length path) 17)) - (error "Could not find slib/require.scm in " %load-path)))) - -(define-public (implementation-vicinity) - (string-append slib-parent-dir "/")) -(define (library-vicinity) - (string-append (implementation-vicinity) "slib/")) -(define (scheme-implementation-type) 'guile) -(define (scheme-implementation-version) "") - -(define (output-port-width . arg) 80) -(define (output-port-height . arg) 24) - -;;; {Time} -;;; - -(define difftime -) -(define offset-time +) - - -(define %system-define define) - -(define define - (procedure->memoizing-macro - (lambda (exp env) - (if (= (length env) 1) - `(define-public ,@(cdr exp)) - `(%system-define ,@(cdr exp)))))) - -(define (software-type) 'UNIX) - -(slib:load (in-vicinity (library-vicinity) "require.scm")) - -(define-public require require:require) - -;; {Extensions to the require system so that the user can add new -;; require modules easily.} - -(define *vicinity-table* - (list - (cons 'implementation (implementation-vicinity)) - (cons 'library (library-vicinity)))) - -(define (install-require-vicinity name vicinity) - (let ((entry (assq name *vicinity-table*))) - (if entry - (set-cdr! entry vicinity) - (set! *vicinity-table* - (acons name vicinity *vicinity-table*))))) - -(define (install-require-module name vicinity-name file-name) - (let ((entry (assq name *catalog*)) - (vicinity (cdr (assq vicinity-name *vicinity-table*)))) - (let ((path-name (in-vicinity vicinity file-name))) - (if entry - (set-cdr! entry path-name) - (set! *catalog* - (acons name path-name *catalog*)))))) diff --git a/ice-9/tags.scm b/ice-9/tags.scm deleted file mode 100644 index 58b7425b4..000000000 --- a/ice-9/tags.scm +++ /dev/null @@ -1,23 +0,0 @@ -;;; installed-scm-file - -;;;; Copyright (C) 1996 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; - - - -(define-module #/ice-9/tags) - diff --git a/ice-9/test.scm b/ice-9/test.scm deleted file mode 100644 index aeb28ee59..000000000 --- a/ice-9/test.scm +++ /dev/null @@ -1,1032 +0,0 @@ -;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. -;; -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;; -;; As a special exception, the Free Software Foundation gives permission -;; for additional uses of the text contained in its release of GUILE. -;; -;; The exception is that, if you link the GUILE library with other files -;; to produce an executable, this does not by itself cause the -;; resulting executable to be covered by the GNU General Public License. -;; Your use of that executable is in no way restricted on account of -;; linking the GUILE library code into it. -;; -;; This exception does not however invalidate any other reasons why -;; the executable file might be covered by the GNU General Public License. -;; -;; This exception applies only to the code released by the -;; Free Software Foundation under the name GUILE. If you copy -;; code from other Free Software Foundation releases into a copy of -;; GUILE, as the General Public License permits, the exception does -;; not apply to the code that you add in this way. To avoid misleading -;; anyone as to the status of such modified files, you must delete -;; this exception notice from them. -;; -;; If you write modifications of your own for GUILE, it is your choice -;; whether to permit this exception to apply to your modifications. -;; If you do not wish that, delete this exception notice. - -;;;; "test.scm" Test correctness of scheme implementations. -;;; Author: Aubrey Jaffer -;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately -;;; won't pass. Made the the tests (test-cont), (test-sc4), and -;;; (test-delay) start to run automatically. - -;;; This includes examples from -;;; William Clinger and Jonathan Rees, editors. -;;; Revised^4 Report on the Algorithmic Language Scheme -;;; and the IEEE specification. - -;;; The input tests read this file expecting it to be named -;;; "test.scm", so you'll have to run it from the ice-9 source -;;; directory, or copy this file elsewhere -;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running -;;; these tests. You may need to delete them in order to run -;;; "test.scm" more than once. - -;;; There are three optional tests: -;;; (TEST-CONT) tests multiple returns from call-with-current-continuation -;;; -;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE -;;; -;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by -;;; either standard. - -;;; If you are testing a R3RS version which does not have `list?' do: -;;; (define list? #f) - -;;; send corrections or additions to jaffer@ai.mit.edu or -;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA - -(define cur-section '())(define errs '()) -(define SECTION (lambda args - (display "SECTION") (write args) (newline) - (set! cur-section args) #t)) -(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) - -(define test - (lambda (expect fun . args) - (write (cons fun args)) - (display " ==> ") - ((lambda (res) - (write res) - (newline) - (cond ((not (equal? expect res)) - (record-error (list res expect (cons fun args))) - (display " BUT EXPECTED ") - (write expect) - (newline) - #f) - (else #t))) - (if (procedure? fun) (apply fun args) (car args))))) -(define (report-errs) - (newline) - (if (null? errs) (display "Passed all tests") - (begin - (display "errors were:") - (newline) - (display "(SECTION (got expected (call)))") - (newline) - (for-each (lambda (l) (write l) (newline)) - errs))) - (newline)) - -(SECTION 2 1);; test that all symbol characters are supported. -'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) - -(SECTION 3 4) -(define disjoint-type-functions - (list boolean? char? null? number? pair? procedure? string? symbol? vector?)) -(define type-examples - (list - #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) )) -(define i 1) -(for-each (lambda (x) (display (make-string i #\ )) - (set! i (+ 3 i)) - (write x) - (newline)) - disjoint-type-functions) -(define type-matrix - (map (lambda (x) - (let ((t (map (lambda (f) (f x)) disjoint-type-functions))) - (write t) - (write x) - (newline) - t)) - type-examples)) -(SECTION 4 1 2) -(test '(quote a) 'quote (quote 'a)) -(test '(quote a) 'quote ''a) -(SECTION 4 1 3) -(test 12 (if #f + *) 3 4) -(SECTION 4 1 4) -(test 8 (lambda (x) (+ x x)) 4) -(define reverse-subtract - (lambda (x y) (- y x))) -(test 3 reverse-subtract 7 10) -(define add4 - (let ((x 4)) - (lambda (y) (+ x y)))) -(test 10 add4 6) -(test '(3 4 5 6) (lambda x x) 3 4 5 6) -(test '(5 6) (lambda (x y . z) z) 3 4 5 6) -(SECTION 4 1 5) -(test 'yes 'if (if (> 3 2) 'yes 'no)) -(test 'no 'if (if (> 2 3) 'yes 'no)) -(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) -(SECTION 4 1 6) -(define x 2) -(test 3 'define (+ x 1)) -(set! x 4) -(test 5 'set! (+ x 1)) -(SECTION 4 2 1) -(test 'greater 'cond (cond ((> 3 2) 'greater) - ((< 3 2) 'less))) -(test 'equal 'cond (cond ((> 3 3) 'greater) - ((< 3 3) 'less) - (else 'equal))) -(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr) - (else #f))) -(test 'composite 'case (case (* 2 3) - ((2 3 5 7) 'prime) - ((1 4 6 8 9) 'composite))) -(test 'consonant 'case (case (car '(c d)) - ((a e i o u) 'vowel) - ((w y) 'semivowel) - (else 'consonant))) -(test #t 'and (and (= 2 2) (> 2 1))) -(test #f 'and (and (= 2 2) (< 2 1))) -(test '(f g) 'and (and 1 2 'c '(f g))) -(test #t 'and (and)) -(test #t 'or (or (= 2 2) (> 2 1))) -(test #t 'or (or (= 2 2) (< 2 1))) -(test #f 'or (or #f #f #f)) -(test #f 'or (or)) -(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0))) -(SECTION 4 2 2) -(test 6 'let (let ((x 2) (y 3)) (* x y))) -(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) -(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) -(test #t 'letrec (letrec ((even? - (lambda (n) (if (zero? n) #t (odd? (- n 1))))) - (odd? - (lambda (n) (if (zero? n) #f (even? (- n 1)))))) - (even? 88))) -(define x 34) -(test 5 'let (let ((x 3)) (define x 5) x)) -(test 34 'let x) -(test 6 'let (let () (define x 6) x)) -(test 34 'let x) -(test 7 'let* (let* ((x 3)) (define x 7) x)) -(test 34 'let* x) -(test 8 'let* (let* () (define x 8) x)) -(test 34 'let* x) -(test 9 'letrec (letrec () (define x 9) x)) -(test 34 'letrec x) -(test 10 'letrec (letrec ((x 3)) (define x 10) x)) -(test 34 'letrec x) -(SECTION 4 2 3) -(define x 0) -(test 6 'begin (begin (set! x 5) (+ x 1))) -(SECTION 4 2 4) -(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) - (i 0 (+ i 1))) - ((= i 5) vec) - (vector-set! vec i i))) -(test 25 'do (let ((x '(1 3 5 7 9))) - (do ((x x (cdr x)) - (sum 0 (+ sum (car x)))) - ((null? x) sum)))) -(test 1 'let (let foo () 1)) -(test '((6 1 3) (-5 -2)) 'let - (let loop ((numbers '(3 -2 1 6 -5)) - (nonneg '()) - (neg '())) - (cond ((null? numbers) (list nonneg neg)) - ((negative? (car numbers)) - (loop (cdr numbers) - nonneg - (cons (car numbers) neg))) - (else - (loop (cdr numbers) - (cons (car numbers) nonneg) - neg))))) -(SECTION 4 2 6) -(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) -(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) -(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) -(test '((foo 7) . cons) - 'quasiquote - `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) - -;;; sqt is defined here because not all implementations are required to -;;; support it. -(define (sqt x) - (do ((i 0 (+ i 1))) - ((> (* i i) x) (- i 1)))) - -(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8)) -(test 5 'quasiquote `,(+ 2 3)) -(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) - 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) -(test '(a `(b ,x ,'y d) e) 'quasiquote - (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) -(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) -(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4))) -(SECTION 5 2 1) -(define add3 (lambda (x) (+ x 3))) -(test 6 'define (add3 3)) -(define first car) -(test 1 'define (first '(1 2))) -(SECTION 5 2 2) -(test 45 'define - (let ((x 5)) - (define foo (lambda (y) (bar x y))) - (define bar (lambda (a b) (+ (* a b) a))) - (foo (+ x 3)))) -(define x 34) -(define (foo) (define x 5) x) -(test 5 foo) -(test 34 'define x) -(define foo (lambda () (define x 5) x)) -(test 5 foo) -(test 34 'define x) -(define (foo x) ((lambda () (define x 5) x)) x) -(test 88 foo 88) -(test 4 foo 4) -(test 34 'define x) -(SECTION 6 1) -(test #f not #t) -(test #f not 3) -(test #f not (list 3)) -(test #t not #f) -;;; Not for Guile -;(test #f not '()) -;(test #f not (list)) -(test #f not 'nil) - -(test #t boolean? #f) -(test #f boolean? 0) -;;; Not for Guile -;(test #f boolean? '()) -(SECTION 6 2) -(test #t eqv? 'a 'a) -(test #f eqv? 'a 'b) -(test #t eqv? 2 2) -(test #t eqv? '() '()) -(test #t eqv? '10000 '10000) -(test #f eqv? (cons 1 2)(cons 1 2)) -(test #f eqv? (lambda () 1) (lambda () 2)) -(test #f eqv? #f 'nil) -(let ((p (lambda (x) x))) - (test #t eqv? p p)) -(define gen-counter - (lambda () - (let ((n 0)) - (lambda () (set! n (+ n 1)) n)))) -(let ((g (gen-counter))) (test #t eqv? g g)) -(test #f eqv? (gen-counter) (gen-counter)) -(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) - (g (lambda () (if (eqv? f g) 'g 'both)))) - (test #f eqv? f g)) - -(test #t eq? 'a 'a) -(test #f eq? (list 'a) (list 'a)) -(test #t eq? '() '()) -(test #t eq? car car) -(let ((x '(a))) (test #t eq? x x)) -(let ((x '#())) (test #t eq? x x)) -(let ((x (lambda (x) x))) (test #t eq? x x)) - -(test #t equal? 'a 'a) -(test #t equal? '(a) '(a)) -(test #t equal? '(a (b) c) '(a (b) c)) -(test #t equal? "abc" "abc") -(test #t equal? 2 2) -(test #t equal? (make-vector 5 'a) (make-vector 5 'a)) -(SECTION 6 3) -(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) -(define x (list 'a 'b 'c)) -(define y x) -(and list? (test #t list? y)) -(set-cdr! x 4) -(test '(a . 4) 'set-cdr! x) -(test #t eqv? x y) -(test '(a b c . d) 'dot '(a . (b . (c . d)))) -(and list? (test #f list? y)) -(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x)))) - -(test #t pair? '(a . b)) -(test #t pair? '(a . 1)) -(test #t pair? '(a b c)) -(test #f pair? '()) -(test #f pair? '#(a b)) - -(test '(a) cons 'a '()) -(test '((a) b c d) cons '(a) '(b c d)) -(test '("a" b c) cons "a" '(b c)) -(test '(a . 3) cons 'a 3) -(test '((a b) . c) cons '(a b) 'c) - -(test 'a car '(a b c)) -(test '(a) car '((a) b c d)) -(test 1 car '(1 . 2)) - -(test '(b c d) cdr '((a) b c d)) -(test 2 cdr '(1 . 2)) - -(test '(a 7 c) list 'a (+ 3 4) 'c) -(test '() list) - -(test 3 length '(a b c)) -(test 3 length '(a (b) (c d e))) -(test 0 length '()) - -(test '(x y) append '(x) '(y)) -(test '(a b c d) append '(a) '(b c d)) -(test '(a (b) (c)) append '(a (b)) '((c))) -(test '() append) -(test '(a b c . d) append '(a b) '(c . d)) -(test 'a append '() 'a) - -(test '(c b a) reverse '(a b c)) -(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f)))) - -(test 'c list-ref '(a b c d) 2) - -(test '(a b c) memq 'a '(a b c)) -(test '(b c) memq 'b '(a b c)) -(test '#f memq 'a '(b c d)) -(test '#f memq (list 'a) '(b (a) c)) -(test '((a) c) member (list 'a) '(b (a) c)) -(test '(101 102) memv 101 '(100 101 102)) - -(define e '((a 1) (b 2) (c 3))) -(test '(a 1) assq 'a e) -(test '(b 2) assq 'b e) -(test #f assq 'd e) -(test #f assq (list 'a) '(((a)) ((b)) ((c)))) -(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c)))) -(test '(5 7) assv 5 '((2 3) (5 7) (11 13))) -(SECTION 6 4) -(test #t symbol? 'foo) -(test #t symbol? (car '(a b))) -(test #f symbol? "bar") -(test #t symbol? 'nil) -(test #f symbol? '()) -(test #f symbol? #f) -;;; But first, what case are symbols in? Determine the standard case: -(define char-standard-case char-upcase) -(if (string=? (symbol->string 'A) "a") - (set! char-standard-case char-downcase)) -;;; Not for Guile -;(test #t 'standard-case -; (string=? (symbol->string 'a) (symbol->string 'A))) -;(test #t 'standard-case -; (or (string=? (symbol->string 'a) "A") -; (string=? (symbol->string 'A) "a"))) -(define (str-copy s) - (let ((v (make-string (string-length s)))) - (do ((i (- (string-length v) 1) (- i 1))) - ((< i 0) v) - (string-set! v i (string-ref s i))))) -(define (string-standard-case s) - (set! s (str-copy s)) - (do ((i 0 (+ 1 i)) - (sl (string-length s))) - ((>= i sl) s) - (string-set! s i (char-standard-case (string-ref s i))))) -;;; Not for Guile -;(test (string-standard-case "flying-fish") symbol->string 'flying-fish) -;(test (string-standard-case "martin") symbol->string 'Martin) -(test "Malvina" symbol->string (string->symbol "Malvina")) -;;; Not for Guile -;(test #t 'standard-case (eq? 'a 'A)) - -(define x (string #\a #\b)) -(define y (string->symbol x)) -(string-set! x 0 #\c) -(test "cb" 'string-set! x) -(test "ab" symbol->string y) -(test y string->symbol "ab") - -;;; Not for Guile -;(test #t eq? 'mISSISSIppi 'mississippi) -;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) -(test 'JollyWog string->symbol (symbol->string 'JollyWog)) - -(SECTION 6 5 5) -(test #t number? 3) -(test #t complex? 3) -(test #t real? 3) -(test #t rational? 3) -(test #t integer? 3) - -(test #t exact? 3) -(test #f inexact? 3) - -(test #t = 22 22 22) -(test #t = 22 22) -(test #f = 34 34 35) -(test #f = 34 35) -(test #t > 3 -6246) -(test #f > 9 9 -2424) -(test #t >= 3 -4 -6246) -(test #t >= 9 9) -(test #f >= 8 9) -(test #t < -1 2 3 4 5 6 7 8) -(test #f < -1 2 3 4 4 5 6 7) -(test #t <= -1 2 3 4 5 6 7 8) -(test #t <= -1 2 3 4 4 5 6 7) -(test #f < 1 3 2) -(test #f >= 1 3 2) - -(test #t zero? 0) -(test #f zero? 1) -(test #f zero? -1) -(test #f zero? -100) -(test #t positive? 4) -(test #f positive? -4) -(test #f positive? 0) -(test #f negative? 4) -(test #t negative? -4) -(test #f negative? 0) -(test #t odd? 3) -(test #f odd? 2) -(test #f odd? -4) -(test #t odd? -1) -(test #f even? 3) -(test #t even? 2) -(test #t even? -4) -(test #f even? -1) - -(test 38 max 34 5 7 38 6) -(test -24 min 3 5 5 330 4 -24) - -(test 7 + 3 4) -(test '3 + 3) -(test 0 +) -(test 4 * 4) -(test 1 *) - -(test -1 - 3 4) -(test -3 - 3) -(test 7 abs -7) -(test 7 abs 7) -(test 0 abs 0) - -(test 5 quotient 35 7) -(test -5 quotient -35 7) -(test -5 quotient 35 -7) -(test 5 quotient -35 -7) -(test 1 modulo 13 4) -(test 1 remainder 13 4) -(test 3 modulo -13 4) -(test -1 remainder -13 4) -(test -3 modulo 13 -4) -(test 1 remainder 13 -4) -(test -1 modulo -13 -4) -(test -1 remainder -13 -4) -(define (divtest n1 n2) - (= n1 (+ (* n2 (quotient n1 n2)) - (remainder n1 n2)))) -(test #t divtest 238 9) -(test #t divtest -238 9) -(test #t divtest 238 -9) -(test #t divtest -238 -9) - -(test 4 gcd 0 4) -(test 4 gcd -4 0) -(test 4 gcd 32 -36) -(test 0 gcd) -(test 288 lcm 32 -36) -(test 1 lcm) - -;;;;From: fred@sce.carleton.ca (Fred J Kaudel) -;;; Modified by jaffer. -(define (test-inexact) - (define f3.9 (string->number "3.9")) - (define f4.0 (string->number "4.0")) - (define f-3.25 (string->number "-3.25")) - (define f.25 (string->number ".25")) - (define f4.5 (string->number "4.5")) - (define f3.5 (string->number "3.5")) - (define f0.0 (string->number "0.0")) - (define f0.8 (string->number "0.8")) - (define f1.0 (string->number "1.0")) - (define wto write-test-obj) - (define dto display-test-obj) - (define lto load-test-obj) - (newline) - (display ";testing inexact numbers; ") - (newline) - (SECTION 6 5 5) - (test #t inexact? f3.9) - (test #t 'inexact? (inexact? (max f3.9 4))) - (test f4.0 'max (max f3.9 4)) - (test f4.0 'exact->inexact (exact->inexact 4)) - (test (- f4.0) round (- f4.5)) - (test (- f4.0) round (- f3.5)) - (test (- f4.0) round (- f3.9)) - (test f0.0 round f0.0) - (test f0.0 round f.25) - (test f1.0 round f0.8) - (test f4.0 round f3.5) - (test f4.0 round f4.5) - (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. - (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) - (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) - (test #t call-with-output-file - "tmp3" - (lambda (test-file) - (write-char #\; test-file) - (display write-test-obj test-file) - (newline test-file) - (write load-test-obj test-file) - (output-port? test-file))) - (check-test-file "tmp3") - (set! write-test-obj wto) - (set! display-test-obj dto) - (set! load-test-obj lto) - (let ((x (string->number "4195835.0")) - (y (string->number "3145727.0"))) - (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) - (report-errs)) - -(define (test-bignum) - (define tb - (lambda (n1 n2) - (= n1 (+ (* n2 (quotient n1 n2)) - (remainder n1 n2))))) - (newline) - (display ";testing bignums; ") - (newline) - (SECTION 6 5 5) - (test 0 modulo -2177452800 86400) - (test 0 modulo 2177452800 -86400) - (test 0 modulo 2177452800 86400) - (test 0 modulo -2177452800 -86400) - (test #t 'remainder (tb 281474976710655 65535)) - (test #t 'remainder (tb 281474976710654 65535)) - (SECTION 6 5 6) - (test 281474976710655 string->number "281474976710655") - (test "281474976710655" number->string 281474976710655) - (report-errs)) - -(SECTION 6 5 6) -(test "0" number->string 0) -(test "100" number->string 100) -(test "100" number->string 256 16) -(test 100 string->number "100") -(test 256 string->number "100" 16) -(test #f string->number "") -(test #f string->number ".") -(test #f string->number "d") -(test #f string->number "D") -(test #f string->number "i") -(test #f string->number "I") -(test #f string->number "3i") -(test #f string->number "3I") -(test #f string->number "33i") -(test #f string->number "33I") -(test #f string->number "3.3i") -(test #f string->number "3.3I") -(test #f string->number "-") -(test #f string->number "+") - -(SECTION 6 6) -(test #t eqv? '#\ #\Space) -(test #t eqv? #\space '#\Space) -(test #t char? #\a) -(test #t char? #\() -(test #t char? #\ ) -(test #t char? '#\newline) - -(test #f char=? #\A #\B) -(test #f char=? #\a #\b) -(test #f char=? #\9 #\0) -(test #t char=? #\A #\A) - -(test #t char<? #\A #\B) -(test #t char<? #\a #\b) -(test #f char<? #\9 #\0) -(test #f char<? #\A #\A) - -(test #f char>? #\A #\B) -(test #f char>? #\a #\b) -(test #t char>? #\9 #\0) -(test #f char>? #\A #\A) - -(test #t char<=? #\A #\B) -(test #t char<=? #\a #\b) -(test #f char<=? #\9 #\0) -(test #t char<=? #\A #\A) - -(test #f char>=? #\A #\B) -(test #f char>=? #\a #\b) -(test #t char>=? #\9 #\0) -(test #t char>=? #\A #\A) - -(test #f char-ci=? #\A #\B) -(test #f char-ci=? #\a #\B) -(test #f char-ci=? #\A #\b) -(test #f char-ci=? #\a #\b) -(test #f char-ci=? #\9 #\0) -(test #t char-ci=? #\A #\A) -(test #t char-ci=? #\A #\a) - -(test #t char-ci<? #\A #\B) -(test #t char-ci<? #\a #\B) -(test #t char-ci<? #\A #\b) -(test #t char-ci<? #\a #\b) -(test #f char-ci<? #\9 #\0) -(test #f char-ci<? #\A #\A) -(test #f char-ci<? #\A #\a) - -(test #f char-ci>? #\A #\B) -(test #f char-ci>? #\a #\B) -(test #f char-ci>? #\A #\b) -(test #f char-ci>? #\a #\b) -(test #t char-ci>? #\9 #\0) -(test #f char-ci>? #\A #\A) -(test #f char-ci>? #\A #\a) - -(test #t char-ci<=? #\A #\B) -(test #t char-ci<=? #\a #\B) -(test #t char-ci<=? #\A #\b) -(test #t char-ci<=? #\a #\b) -(test #f char-ci<=? #\9 #\0) -(test #t char-ci<=? #\A #\A) -(test #t char-ci<=? #\A #\a) - -(test #f char-ci>=? #\A #\B) -(test #f char-ci>=? #\a #\B) -(test #f char-ci>=? #\A #\b) -(test #f char-ci>=? #\a #\b) -(test #t char-ci>=? #\9 #\0) -(test #t char-ci>=? #\A #\A) -(test #t char-ci>=? #\A #\a) - -(test #t char-alphabetic? #\a) -(test #t char-alphabetic? #\A) -(test #t char-alphabetic? #\z) -(test #t char-alphabetic? #\Z) -(test #f char-alphabetic? #\0) -(test #f char-alphabetic? #\9) -(test #f char-alphabetic? #\space) -(test #f char-alphabetic? #\;) - -(test #f char-numeric? #\a) -(test #f char-numeric? #\A) -(test #f char-numeric? #\z) -(test #f char-numeric? #\Z) -(test #t char-numeric? #\0) -(test #t char-numeric? #\9) -(test #f char-numeric? #\space) -(test #f char-numeric? #\;) - -(test #f char-whitespace? #\a) -(test #f char-whitespace? #\A) -(test #f char-whitespace? #\z) -(test #f char-whitespace? #\Z) -(test #f char-whitespace? #\0) -(test #f char-whitespace? #\9) -(test #t char-whitespace? #\space) -(test #f char-whitespace? #\;) - -(test #f char-upper-case? #\0) -(test #f char-upper-case? #\9) -(test #f char-upper-case? #\space) -(test #f char-upper-case? #\;) - -(test #f char-lower-case? #\0) -(test #f char-lower-case? #\9) -(test #f char-lower-case? #\space) -(test #f char-lower-case? #\;) - -(test #\. integer->char (char->integer #\.)) -(test #\A integer->char (char->integer #\A)) -(test #\a integer->char (char->integer #\a)) -(test #\A char-upcase #\A) -(test #\A char-upcase #\a) -(test #\a char-downcase #\A) -(test #\a char-downcase #\a) -(SECTION 6 7) -(test #t string? "The word \"recursion\\\" has many meanings.") -(test #t string? "") -(define f (make-string 3 #\*)) -(test "?**" 'string-set! (begin (string-set! f 0 #\?) f)) -(test "abc" string #\a #\b #\c) -(test "" string) -(test 3 string-length "abc") -(test #\a string-ref "abc" 0) -(test #\c string-ref "abc" 2) -(test 0 string-length "") -(test "" substring "ab" 0 0) -(test "" substring "ab" 1 1) -(test "" substring "ab" 2 2) -(test "a" substring "ab" 0 1) -(test "b" substring "ab" 1 2) -(test "ab" substring "ab" 0 2) -(test "foobar" string-append "foo" "bar") -(test "foo" string-append "foo") -(test "foo" string-append "foo" "") -(test "foo" string-append "" "foo") -(test "" string-append) -(test "" make-string 0) -(test #t string=? "" "") -(test #f string<? "" "") -(test #f string>? "" "") -(test #t string<=? "" "") -(test #t string>=? "" "") -(test #t string-ci=? "" "") -(test #f string-ci<? "" "") -(test #f string-ci>? "" "") -(test #t string-ci<=? "" "") -(test #t string-ci>=? "" "") - -(test #f string=? "A" "B") -(test #f string=? "a" "b") -(test #f string=? "9" "0") -(test #t string=? "A" "A") - -(test #t string<? "A" "B") -(test #t string<? "a" "b") -(test #f string<? "9" "0") -(test #f string<? "A" "A") - -(test #f string>? "A" "B") -(test #f string>? "a" "b") -(test #t string>? "9" "0") -(test #f string>? "A" "A") - -(test #t string<=? "A" "B") -(test #t string<=? "a" "b") -(test #f string<=? "9" "0") -(test #t string<=? "A" "A") - -(test #f string>=? "A" "B") -(test #f string>=? "a" "b") -(test #t string>=? "9" "0") -(test #t string>=? "A" "A") - -(test #f string-ci=? "A" "B") -(test #f string-ci=? "a" "B") -(test #f string-ci=? "A" "b") -(test #f string-ci=? "a" "b") -(test #f string-ci=? "9" "0") -(test #t string-ci=? "A" "A") -(test #t string-ci=? "A" "a") - -(test #t string-ci<? "A" "B") -(test #t string-ci<? "a" "B") -(test #t string-ci<? "A" "b") -(test #t string-ci<? "a" "b") -(test #f string-ci<? "9" "0") -(test #f string-ci<? "A" "A") -(test #f string-ci<? "A" "a") - -(test #f string-ci>? "A" "B") -(test #f string-ci>? "a" "B") -(test #f string-ci>? "A" "b") -(test #f string-ci>? "a" "b") -(test #t string-ci>? "9" "0") -(test #f string-ci>? "A" "A") -(test #f string-ci>? "A" "a") - -(test #t string-ci<=? "A" "B") -(test #t string-ci<=? "a" "B") -(test #t string-ci<=? "A" "b") -(test #t string-ci<=? "a" "b") -(test #f string-ci<=? "9" "0") -(test #t string-ci<=? "A" "A") -(test #t string-ci<=? "A" "a") - -(test #f string-ci>=? "A" "B") -(test #f string-ci>=? "a" "B") -(test #f string-ci>=? "A" "b") -(test #f string-ci>=? "a" "b") -(test #t string-ci>=? "9" "0") -(test #t string-ci>=? "A" "A") -(test #t string-ci>=? "A" "a") -(SECTION 6 8) -(test #t vector? '#(0 (2 2 2 2) "Anna")) -(test #t vector? '#()) -(test '#(a b c) vector 'a 'b 'c) -(test '#() vector) -(test 3 vector-length '#(0 (2 2 2 2) "Anna")) -(test 0 vector-length '#()) -(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5) -(test '#(0 ("Sue" "Sue") "Anna") 'vector-set - (let ((vec (vector 0 '(2 2 2 2) "Anna"))) - (vector-set! vec 1 '("Sue" "Sue")) - vec)) -(test '#(hi hi) make-vector 2 'hi) -(test '#() make-vector 0) -(test '#() make-vector 0 'a) -(SECTION 6 9) -(test #t procedure? car) -(test #f procedure? 'car) -(test #t procedure? (lambda (x) (* x x))) -(test #f procedure? '(lambda (x) (* x x))) -(test #t call-with-current-continuation procedure?) -(test 7 apply + (list 3 4)) -(test 7 apply (lambda (a b) (+ a b)) (list 3 4)) -(test 17 apply + 10 (list 3 4)) -(test '() apply list '()) -(define compose (lambda (f g) (lambda args (f (apply g args))))) -(test 30 (compose sqt *) 12 75) - -(test '(b e h) map cadr '((a b) (d e) (g h))) -(test '(5 7 9) map + '(1 2 3) '(4 5 6)) -(test '#(0 1 4 9 16) 'for-each - (let ((v (make-vector 5))) - (for-each (lambda (i) (vector-set! v i (* i i))) - '(0 1 2 3 4)) - v)) -(test -3 call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) (if (negative? x) (exit x))) - '(54 0 37 -3 245 19)) - #t)) -(define list-length - (lambda (obj) - (call-with-current-continuation - (lambda (return) - (letrec ((r (lambda (obj) (cond ((null? obj) 0) - ((pair? obj) (+ (r (cdr obj)) 1)) - (else (return #f)))))) - (r obj)))))) -(test 4 list-length '(1 2 3 4)) -(test #f list-length '(a b . c)) -(test '() map cadr '()) - -;;; This tests full conformance of call-with-current-continuation. It -;;; is a separate test because some schemes do not support call/cc -;;; other than escape procedures. I am indebted to -;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this -;;; code. The function leaf-eq? compares the leaves of 2 arbitrary -;;; trees constructed of conses. -(define (next-leaf-generator obj eot) - (letrec ((return #f) - (cont (lambda (x) - (recur obj) - (set! cont (lambda (x) (return eot))) - (cont #f))) - (recur (lambda (obj) - (if (pair? obj) - (for-each recur obj) - (call-with-current-continuation - (lambda (c) - (set! cont c) - (return obj))))))) - (lambda () (call-with-current-continuation - (lambda (ret) (set! return ret) (cont #f)))))) -(define (leaf-eq? x y) - (let* ((eot (list 'eot)) - (xf (next-leaf-generator x eot)) - (yf (next-leaf-generator y eot))) - (letrec ((loop (lambda (x y) - (cond ((not (eq? x y)) #f) - ((eq? eot x) #t) - (else (loop (xf) (yf))))))) - (loop (xf) (yf))))) -(define (test-cont) - (newline) - (display ";testing continuations; ") - (newline) - (SECTION 6 9) - (test #t leaf-eq? '(a (b (c))) '((a) b c)) - (test #f leaf-eq? '(a (b (c))) '((a) b c d)) - (report-errs)) - -;;; Test Optional R4RS DELAY syntax and FORCE procedure -(define (test-delay) - (newline) - (display ";testing DELAY and FORCE; ") - (newline) - (SECTION 6 9) - (test 3 'delay (force (delay (+ 1 2)))) - (test '(3 3) 'delay (let ((p (delay (+ 1 2)))) - (list (force p) (force p)))) - (test 2 'delay (letrec ((a-stream - (letrec ((next (lambda (n) - (cons n (delay (next (+ n 1))))))) - (next 0))) - (head car) - (tail (lambda (stream) (force (cdr stream))))) - (head (tail (tail a-stream))))) - (letrec ((count 0) - (p (delay (begin (set! count (+ count 1)) - (if (> count x) - count - (force p))))) - (x 5)) - (test 6 force p) - (set! x 10) - (test 6 force p)) - (test 3 'force - (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1))))) - (c #f)) - (force p))) - (report-errs)) - -(SECTION 6 10 1) -(test #t input-port? (current-input-port)) -(test #t output-port? (current-output-port)) -(test #t call-with-input-file "test.scm" input-port?) -(define this-file (open-input-file "test.scm")) -(test #t input-port? this-file) -(SECTION 6 10 2) -(test #\; peek-char this-file) -(test #\; read-char this-file) -(test '(define cur-section '()) read this-file) -(test #\( peek-char this-file) -(test '(define errs '()) read this-file) -(close-input-port this-file) -(close-input-port this-file) -(define (check-test-file name) - (define test-file (open-input-file name)) - (test #t 'input-port? - (call-with-input-file - name - (lambda (test-file) - (test load-test-obj read test-file) - (test #t eof-object? (peek-char test-file)) - (test #t eof-object? (read-char test-file)) - (input-port? test-file)))) - (test #\; read-char test-file) - (test display-test-obj read test-file) - (test load-test-obj read test-file) - (close-input-port test-file)) -(SECTION 6 10 3) -(define write-test-obj - '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) -(define display-test-obj - '(#t #f a () 9739 -3 . #((test) te " " st test #() b c))) -(define load-test-obj - (list 'define 'foo (list 'quote write-test-obj))) -(test #t call-with-output-file - "tmp1" - (lambda (test-file) - (write-char #\; test-file) - (display write-test-obj test-file) - (newline test-file) - (write load-test-obj test-file) - (output-port? test-file))) -(check-test-file "tmp1") - -(define test-file (open-output-file "tmp2")) -(write-char #\; test-file) -(display write-test-obj test-file) -(newline test-file) -(write load-test-obj test-file) -(test #t output-port? test-file) -(close-output-port test-file) -(check-test-file "tmp2") -(define (test-sc4) - (newline) - (display ";testing scheme 4 functions; ") - (newline) - (SECTION 6 7) - (test '(#\P #\space #\l) string->list "P l") - (test '() string->list "") - (test "1\\\"" list->string '(#\1 #\\ #\")) - (test "" list->string '()) - (SECTION 6 8) - (test '(dah dah didah) vector->list '#(dah dah didah)) - (test '() vector->list '#()) - (test '#(dididit dah) list->vector '(dididit dah)) - (test '#() list->vector '()) - (SECTION 6 10 4) - (load "tmp1") - (test write-test-obj 'load foo) - (report-errs)) - -(report-errs) -(if (and (string->number "0.0") (inexact? (string->number "0.0"))) - (test-inexact)) - -(let ((n (string->number "281474976710655"))) - (if (and n (exact? n)) - (test-bignum))) -(newline) -(test-cont) -(newline) -(test-sc4) -(newline) -(test-delay) -(newline) -"last item in file" diff --git a/ice-9/threads.scm b/ice-9/threads.scm deleted file mode 100644 index bec189009..000000000 --- a/ice-9/threads.scm +++ /dev/null @@ -1,53 +0,0 @@ -;;;; Copyright (C) 1996 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;;;; -;;;; ---------------------------------------------------------------- -;;;; threads.scm -- User-level interface to Guile's thread system -;;;; 4 March 1996, Anthony Green <green@cygnus.com> -;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se> -;;;; ---------------------------------------------------------------- -;;;; - - -(define-module #/ice-9/threads) - - - -; --- MACROS ------------------------------------------------------- - -(defmacro-public make-thread (fn . args) - `(call-with-new-thread - (lambda () - (,fn ,@args)) - (lambda args args))) - -(defmacro-public begin-thread (first . thunk) - `(call-with-new-thread - (lambda () - (begin - ,first ,@thunk)) - (lambda args args))) - -(defmacro-public with-mutex (m . thunk) - `(dynamic-wind - (lambda () (lock-mutex ,m)) - (lambda () (begin ,@thunk)) - (lambda () (unlock-mutex ,m)))) - -(defmacro-public monitor (first . thunk) - `(with-mutex ,(make-mutex) - (begin - ,first ,@thunk))) diff --git a/install-sh b/install-sh deleted file mode 100755 index ab74c882e..000000000 --- a/install-sh +++ /dev/null @@ -1,238 +0,0 @@ -#!/bin/sh -# -# install - install a program, script, or datafile -# This comes from X11R5. -# -# Calling this script install-sh is preferred over install.sh, to prevent -# `make' implicit rules from creating a file called install from it -# when there is no Makefile. -# -# This script is compatible with the BSD install script, but was written -# from scratch. -# - - -# set DOITPROG to echo to test this script - -# Don't use :- since 4.3BSD and earlier shells don't like it. -doit="${DOITPROG-}" - - -# put in absolute paths if you don't have them in your path; or use env. vars. - -mvprog="${MVPROG-mv}" -cpprog="${CPPROG-cp}" -chmodprog="${CHMODPROG-chmod}" -chownprog="${CHOWNPROG-chown}" -chgrpprog="${CHGRPPROG-chgrp}" -stripprog="${STRIPPROG-strip}" -rmprog="${RMPROG-rm}" -mkdirprog="${MKDIRPROG-mkdir}" - -tranformbasename="" -transform_arg="" -instcmd="$mvprog" -chmodcmd="$chmodprog 0755" -chowncmd="" -chgrpcmd="" -stripcmd="" -rmcmd="$rmprog -f" -mvcmd="$mvprog" -src="" -dst="" -dir_arg="" - -while [ x"$1" != x ]; do - case $1 in - -c) instcmd="$cpprog" - shift - continue;; - - -d) dir_arg=true - shift - continue;; - - -m) chmodcmd="$chmodprog $2" - shift - shift - continue;; - - -o) chowncmd="$chownprog $2" - shift - shift - continue;; - - -g) chgrpcmd="$chgrpprog $2" - shift - shift - continue;; - - -s) stripcmd="$stripprog" - shift - continue;; - - -t=*) transformarg=`echo $1 | sed 's/-t=//'` - shift - continue;; - - -b=*) transformbasename=`echo $1 | sed 's/-b=//'` - shift - continue;; - - *) if [ x"$src" = x ] - then - src=$1 - else - # this colon is to work around a 386BSD /bin/sh bug - : - dst=$1 - fi - shift - continue;; - esac -done - -if [ x"$src" = x ] -then - echo "install: no input file specified" - exit 1 -else - true -fi - -if [ x"$dir_arg" != x ]; then - dst=$src - src="" - - if [ -d $dst ]; then - instcmd=: - else - instcmd=mkdir - fi -else - -# Waiting for this to be detected by the "$instcmd $src $dsttmp" command -# might cause directories to be created, which would be especially bad -# if $src (and thus $dsttmp) contains '*'. - - if [ -f $src -o -d $src ] - then - true - else - echo "install: $src does not exist" - exit 1 - fi - - if [ x"$dst" = x ] - then - echo "install: no destination specified" - exit 1 - else - true - fi - -# If destination is a directory, append the input filename; if your system -# does not like double slashes in filenames, you may need to add some logic - - if [ -d $dst ] - then - dst="$dst"/`basename $src` - else - true - fi -fi - -## this sed command emulates the dirname command -dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` - -# Make sure that the destination directory exists. -# this part is taken from Noah Friedman's mkinstalldirs script - -# Skip lots of stat calls in the usual case. -if [ ! -d "$dstdir" ]; then -defaultIFS=' -' -IFS="${IFS-${defaultIFS}}" - -oIFS="${IFS}" -# Some sh's can't handle IFS=/ for some reason. -IFS='%' -set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` -IFS="${oIFS}" - -pathcomp='' - -while [ $# -ne 0 ] ; do - pathcomp="${pathcomp}${1}" - shift - - if [ ! -d "${pathcomp}" ] ; - then - $mkdirprog "${pathcomp}" - else - true - fi - - pathcomp="${pathcomp}/" -done -fi - -if [ x"$dir_arg" != x ] -then - $doit $instcmd $dst && - - if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi -else - -# If we're going to rename the final executable, determine the name now. - - if [ x"$transformarg" = x ] - then - dstfile=`basename $dst` - else - dstfile=`basename $dst $transformbasename | - sed $transformarg`$transformbasename - fi - -# don't allow the sed command to completely eliminate the filename - - if [ x"$dstfile" = x ] - then - dstfile=`basename $dst` - else - true - fi - -# Make a temp file name in the proper directory. - - dsttmp=$dstdir/#inst.$$# - -# Move or copy the file name to the temp name - - $doit $instcmd $src $dsttmp && - - trap "rm -f ${dsttmp}" 0 && - -# and set any options; do chmod last to preserve setuid bits - -# If any of these fail, we abort the whole thing. If we want to -# ignore errors from any of these, just make sure not to ignore -# errors from the above "$doit $instcmd $src $dsttmp" command. - - if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && - if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && - if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && - if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && - -# Now rename the file to the real destination. - - $doit $rmcmd -f $dstdir/$dstfile && - $doit $mvcmd $dsttmp $dstdir/$dstfile - -fi && - - -exit 0 diff --git a/libguile/.cvsignore b/libguile/.cvsignore deleted file mode 100644 index e4632e405..000000000 --- a/libguile/.cvsignore +++ /dev/null @@ -1,8 +0,0 @@ -Makefile -config.log -config.status -config.cache -fd.h -scmconfig.h -*.x -libpath.h
\ No newline at end of file diff --git a/libguile/COPYING b/libguile/COPYING deleted file mode 100644 index 9648fb9ea..000000000 --- a/libguile/COPYING +++ /dev/null @@ -1,339 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991, 1992, 1993 Free Software Foundation, Inc. - 675 Mass Ave, Cambridge, MA 02139, USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) You can apply it to -your programs, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. You must make sure that they, too, receive or can get the -source code. And you must show them these terms so they know their -rights. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute verbatim copies of the Program's -source code as you receive it, in any medium, provided that you -conspicuously and appropriately publish on each copy an appropriate -copyright notice and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the General Public License from time to time. Such new versions will -be similar in spirit to the present version, but may differ in detail to -address new problems or concerns. - -Each version is given a distinguishing version number. If the Program -specifies a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY -FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN -OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES -PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED -OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS -TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE -PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, -INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING -OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED -TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY -YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER -PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - - END OF TERMS AND CONDITIONS - - Appendix: How to Apply These Terms to Your New Programs - - If you develop a new program, and you want it to be of the greatest -possible use to the public, the best way to achieve this is to make it -free software which everyone can redistribute and change under these terms. - - To do so, attach the following notices to the program. It is safest -to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least -the "copyright" line and a pointer to where the full notice is found. - - <one line to give the program's name and a brief idea of what it does.> - Copyright (C) 19yy <name of author> - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) 19yy name of author - Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. - This is free software, and you are welcome to redistribute it - under certain conditions; type `show c' for details. - -The hypothetical commands `show w' and `show c' should show the appropriate -parts of the General Public License. Of course, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - <signature of Ty Coon>, 1 April 1989 - Ty Coon, President of Vice - -This General Public License does not permit incorporating your program into -proprietary programs. If your program is a subroutine library, you may -consider it more useful to permit linking proprietary applications with the -library. If this is what you want to do, use the GNU Library General -Public License instead of this License. diff --git a/libguile/ChangeLog-scm b/libguile/ChangeLog-scm deleted file mode 100644 index 0ba497ed7..000000000 --- a/libguile/ChangeLog-scm +++ /dev/null @@ -1,2610 +0,0 @@ -Wed Apr 5 14:32:51 1995 Gary Houston <ghouston@actrix.gen.nz> - - * unix.c, ioext.c, posix.c, sys.c: Scheme name changes, - semantic cleanups, the port table, missing system calls - and coding cleanups from ghouston@actrix.gen.nz - -Thu Mar 16 14:37:38 1995 Tom Lord <lord@x1.cygnus.com> - - * guile.c: fixed the gcc-specific definition of the macro "AT(x)". - - * guile.c (gscm_init_from_fn): Parameterize what init functions - get called (see guile_ks, below). - - * guile-mini.c (guile_mini): a minimalist alternative to guile_ks. - - * guile-ks.c (guile_ks): factor out the call to optional inits to - a separate file so you can link against libguile without getting - the kitchen sink. - - * Ginit.scm (try-load of "ScmInit.scm"): Be robust in the absense - of a binding for the environment varialbe HOME. Try - (getpw (geteuid)) or just use "/". - - -Thu Mar 9 15:35:20 1995 Tom Lord <lord@x1.cygnus.com> - - * gmain.c (main): Print additional error message if init file - can't be opened. - - * guile.c (initialize_gscm): Report an error if the - init file can't be opened. - -Thu Mar 23 23:22:59 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.texi (I/O-Extensions): Finished. - - * Init.scm (scm:load): `loading' messages now indented. - -Sat Mar 4 20:58:51 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.texi: documentation finished for "posix.c" and "unix.c". - - * posix.c (scm_getgroups): added. - - * posix.c (makfrom0str): According to glibc.info, some field in - structures like pwent may have NULL pointers. Changed makfrom0str - to return BOOL_F in this case. - -Thu Mar 2 12:52:25 1995 Aubrey Jaffer (jaffer@jacal) - - * time.c: CLKTCK set from CLOCKS_PER_SEC, if available. Metaware - HighC ported. - - * scm.h: USE_ANSI_PROTOTYPES now controls prototypes (was - __STDC__). This allows an overly fussy compiler to still have - __STDC__. - - From: dorai@ses.com (Dorai Sitaram) - * ioext.c (l_utime): include files fixed for __EMX__ - -Sun Feb 26 23:46:18 1995 Tom Lord <lord@x1.cygnus.com> - - * repl.c (scm_app_wdr): Like scm_apply, but takes an error function. - The caller's continuation is never captured or escaped. - The error function is invoked as with scm_cwdr. - -Sun Feb 26 21:03:04 1995 Aubrey Jaffer (jaffer@jacal) - - * sys.c (gc_mark gc_sweep): tc7_ssymbol now gets GCed because it - gets used for non-GCed strings in scm_evalstr scm_loadstr. - (mkstrport cwos cwis): changed so caller's name is passed into - mkstrport(). - - * repl.c - (scm_eval_string scm_evalstr scm_load_string scm_loadstr): added - for easier C to scheme callbacks. - (loadport): variable added so lreadr() and flush_ws() - increment linum only when reading from the correct port. - (def_err_response): now handles ARGn for argument numbers > 5 and - unknown position arguments. - - * dynl.c: Dynamic Linking now sets and restores *load-pathname* - around the init_ call. - -Sat Feb 25 11:03:56 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.c (lsystem getenv softtype ed vms_debug): moved from scl.c. - (add_feature): moved from repl.c. - (features): init table removed (caused multiple symbols). - -Fri Feb 24 23:48:03 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.c (scm_init_extensions COMPILED_INITS): Added so that - statically linked, compiled code can be initialized *after* most - of Init.scm has loaded. - -Wed Feb 22 15:54:01 1995 Aubrey Jaffer (jaffer@jacal) - - * subr.c (append): Added check for bad arguments and fixed errobj. - -Sun Feb 19 01:31:59 1995 Aubrey Jaffer (jaffer@jacal) - - * ioext.c (exec execp): changed so that 2nd arguments is argv[0] - (like posix) and renamed to execl and execlp. - (execv execvp): added. - -Sat Feb 11 17:30:14 1995 Aubrey Jaffer (jaffer@jacal) - - * ioext.c (lexec): moved from repl.c and scm.c. - (lexecp i_exec l_putenv): added. - - * posix.c (open_pipe l_open_input_pipe l_open_output_pipe - prinpipe): moved from ioext.c. - (l_fork): added. - -Fri Feb 10 10:50:03 1995 Aubrey Jaffer (jaffer@jacal) - - * scl.c (num2long long2num): moved here from subr.c. - (num2ulong): fixed (< to >=) bug. - - * unif.c (aset array2list array_ref cvref): uniform integers and - unsigned integer arrays now handle full size integers (and - inexacts) using num2long, num2ulong, long2num, and ulong2num when - INUMS_ONLY is not defined. - - * scmfig.h (INUMS_ONLY): defined when INUMs are the only numbers. - -Wed Feb 8 17:57:26 1995 Tom Lord (lord@x1.cygnus.com) - - * Ginit.scm (stand-alone-repl): Use new function (rooted-repl) - (rooted-repl): new function - -Tue Jan 31 16:46:26 1995 Tom Lord (lord@x1.cygnus.com) - - * repl.c (lreadr): compare string constant names - in a case insensative way. - - (scm_lread): Take an optional parameter CASEP. - If specified and not #f, then symbols are read - in a case sensative way. - - If not specified, the state variable default_case_i is checked - (a C int, either 0 or 1). The state variable hasn't been - exposed and so is constant and depends on compile-time flags -- - but in the future it might be made more explicit if there is a - need. - -Sun Jan 29 23:22:40 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.texi (Overview): scm.1 converted to texinfo format and - incorporated. - -Sat Jan 28 23:11:40 1995 Tom Lord (lord@x1.cygnus.com) - - * repl.c (compiled-library-path): return the value of the - compile-time cpp macro "LIBRARY_PATH" or #f. - - * Ginit.scm: use the above path to find slib on unix. - This solution should be generalized. - -Fri Jan 27 19:58:27 1995 Tom Lord (lord@x1.cygnus.com) - - * sys.c (gc_sweep): Fixed a gc bug that caused circular free-lists - resulting in Cells that thought they were free long after they - were allocated for some nefarious purpose or other. - - * Makefile.in (manifest): ship all pieces of the info manual. - Typos fixes from ghouston. - -Thu Jan 26 01:52:00 1995 Tom Lord <lord@x1.cygnus.com> - - From: cessu@cs.hut.fi (Kenneth Oksanen) - - * configure.in: - AC_CHECK_LIB(nsl, gethostent) - AC_CHECK_LIB(ucb, bzero) - AC_CHECK_LIB(socket, socket) - AC_CHECK_LIB(bsd, bzero) - - - From: brent@jade.ssd.csd.harris.com (Brent Benson) - - * gmain.c: line 31: In ANSI C, string literals cannot span multiple - source lines. - - * guile.c: line 592: The two cases in the ifdef are reversed, AT(X) - should expand to nothing if you are *not* using GNUC. - - * ioext.c: line 29: On my system it is necessary to - include <unistd.h> *before* <sys/stat.h> in order to - have the correct types defined. - - * ioext.c: line 194: Declaration of popen conflicts with my system's - popen() defined in <unistd.h>. Let the header file provide the - prototype!! - -Sun Jan 22 11:13:58 1995 Aubrey Jaffer (jaffer@jacal) - - * scm.texi (Internals): code.doc converted to texinfo format. - Much added and reorganized. code.doc removed. - -Thu Jan 19 00:40:11 1995 Aubrey Jaffer (jaffer@jacal) - - * subr.c (logbitp logtest): added. - -Mon Jan 16 01:42:20 1995 Tom Lord <lord@x1.cygnus.com> - - * repl.c (scm_repl): takes two arguments now (prompt and top-level). - Callable from Scheme. - - * sys.c (scm_init_storage): only use stdin if scm_take_stdin is true. - Otherwise, use an empty string port. If using stdin, make it - unbuffered. - -Sun Jan 15 21:51:37 1995 Tom Lord <lord@x1.cygnus.com> - - * sys.c (scm_mkarray, scm_free_array, mark_arrays): support for - C programs. malloc/free style interface to allcoating - protected storage of type SCM*. - -Sun Jan 15 17:49:43 1995 Tom Lord (lord@x1.cygnus.com) - - * guile.c: new file. Friendly C interface for Guile. - (see file GUILE) - - * repl.c (scm_cwdr): added call-with-dynamic-root (see scm.texi). - -Sat Jan 14 23:35:21 1995 Tom Lord (lord@x1.cygnus.com) - - * repl.c, subr.c: re-arrangement, commenting - of source in preparation for pulling repls apart - for libguile. - -Wed Jan 11 14:45:17 1995 Aubrey Jaffer (jaffer@jacal) - - * scl.c (num2ulong): checks for bignum sign and magnitude added. - - * subr.c (logand logior logxor lognot): lognot restriction to - INUMs removed. Logand, logior, and logxor now will work for up to - 32 bit signed numbers. - -Tue Jan 10 13:19:52 1995 Aubrey Jaffer (jaffer@jacal) - - * repl.c (def_err_response): Circuitous call to quit() replaced - with exit(EXIT_FAILURE); - (everr): Now calls def_err_response() in interrupt frame if - errjmp_bad or there are dynwinds to do. This prevents silent - failure in batch mode. - - -Mon Jan 9 00:12:14 1995 Aubrey Jaffer (jaffer@jacal) - - * repl.c (handle_it): Now discards possibly used top freelist cell - for GC safety. Also now just punts if errjmp_bad. - - * scm.texi: converted from MANUAL. GUILE documentation merged in. - -Sat Jan 7 13:51:04 1995 Miles Bader (miles@eskimo.com) - - * mrequire.scm: New file: Wrapper for slib require/provide that - makes it modular (that is, each slib package is loaded into its - own module, and sees only other modules that it requires). - - * defmod.scm: Allow use-interface in the default module. - - * libguile.scm: Put symbols common to both guile and scm - interfaces into the internal interface `EXTRA' (which is included - by both). Other random shuffling, mostly to make slib happy. - - * modops.scm (extend-interface, export-interface, export): Add - another operation type, #f, which turns off automatic exporting of - the current source interface when finishing up with it. This is - used by export-interface to prevent trying to export all symbols. - - * modops.scm (import): No longer signal an error when trying to - export a whole module, as we want to do this sometimes. - - * Ginit.scm: No longer try to load require.scm, or depend on it; - In the case of getopt, we just load it manually. Also make - defmacro module-safe. - -Sat Jan 7 01:54:11 1995 Tom Lord <lord@x1.cygnus.com> - - * sys.c (scm_intern_obarray_soft): Reserve room for symbol slots. - - * sys.c (scm_makstr, scm_makfromstr): added an extra parameter SLOTS. - The parameter means: - 0: same as the old behavior - 1: not useful - > 1: allocate SLOTS - 1 extra slots in the string storage. - - The base address of SLOTS, an array of SCM, is at SLOTS(obj). - This is for symbol slots, and later for procedure slots. - If you use this in the constructor for your new type (usually - done by creating a string and then invoking SETLENGTH to change - its type), you are responsible for making sure slot contents - are properly gc'ed. - - Callers of these were fixed as well. - -Tue Jan 3 14:30:34 1995 Miles Bader (miles@eskimo.com) - - * modops.scm, extlibs.scm, libguile.scm, defmod.scm: New files: - These implement the user-level module system. - - * sys.c (scm_sym2vcell): Add another argument: definedp, which is - passed as additional argument to the lookup-thunk (if any). - If this argument is BOOL_T, this lookup is for a define (which - has somewhat different semantics for modules); otherwise it - should be satisfied with an existing variable. If the thunk - returns BOOL_F (meaning there was no such variable), sym2vcell - returns BOOL_F as well. - * eval.c (scm_lookupcar, scm_m_define): Use the new sym2vcell param. - * variable.c (scm_builtin_var): Use the new sym2vcell param. - - * eval.c (scm_top_level_env): New function: return an environment - using the given top-level-lookup thunk. - * eval.c (scm_eval2): Use scm_top_level_env. - * eval.c (scm_eval): Use an env with a top-level lookup thunk from - scm_top_level_lookup_thunk_var (aka *top-level-lookup-thunk*). - * eval.c (scm_neval): New function: just like scm_eval, but may - destroy its argument. Known in scheme as eval!. - - * repl.c (scm_repl, scm_tryload, lreadr): Use scm_neval, not eval_3. - - * Ginit.scm (make-module): Use the new definition of top-level thunks. - * Ginit.scm (set-current-module): Set *top-level-lookup-thunk* too. - * Ginit.scm: Trash all the repl stuff; we just use the C repl now. - Load the user module system. - - * Makefile.in: Install the user-module implementation files. - -Mon Jan 2 16:27:25 1995 Miles Bader (miles@eskimo.com) - - * Ginit.scm (repl:repl): Have the guile repl redefine try-load - instead of load, as this is the SCM primitive. - (module-for-each): Write module-for-each. - (module-search): Make this recurse into each module use-list - entry, as per the low-level module spec. - (define-macro): Make this function usable by modules that don't - have access to the internals of the guile module. - -Sun Jan 1 22:30:25 1995 Tom Lord <lord@x1.cygnus.com> - - * repl.c (scm_iprin1), subr.c (scm_lock_vector, scm_unlock_vector, - scm_lvector_ref, scm_lvector_set): - - Added locked vectors. See N - -Sat Dec 31 15:45:22 1994 Miles Bader <miles@eskimo.com> - - * Ginit.scm: - Add define-macro, delq!. - - Add a module print-function, and some new name fields - to the module that the modops code uses to make modules - print nicely (e.g., #<interface guile/module 7a89c>) - - - * eval.c(ceval): Here's a patch that makes closures & subrs - self-evaluating. - - -Wed Dec 28 00:31:22 1994 Tom Lord <lord@cygnus.com> - - * scm.c (raise): use kill not raise, since it is more portable. - -Wed Dec 21 05:18:47 1994 Tom Lord <lord@x1.cygnus.com> - - * eval.c (scm_eval2): Two argument eval. The - second argument is #f or a proc returning a variable. - -Fri Dec 9 00:40:26 1994 Tom Lord <lord@x1.cygnus.com> - - * eval.c (scm_fasl_eval): eval without copying the source form. - This is just a temporary hack. - -Sun Dec 4 21:50:37 1994 Tom Lord <lord@x1.cygnus.com> - - * eval.c (scm_ceval): Added special forms LITERAL-VARIABLE-SET! - and LITERAL-VARIABLE-REF. The first argument of each is a - variable object (see variable.c). The second argument - of set! is an expression. They do what you'd expect. - -SET! returns UNSPECIFIED. - - Note that one can not read a form which uses literal-variable* - correctly because there is no way to read a variable object. - These forms exist for the sake of the module system. - -Fri Dec 2 19:52:40 1994 Tom Lord (lord@x1.cygnus.com) - - * subr.c (string->obarray-symbol, intern-symbol, unintern-symbol, - symbol-set!, symbol-binding) - Multiple obarrays. - - * variable.c (scm_make_variable, scm_variable_{ref,set} - Implemented variables. Variables are anonymous - objects holding one settable value. - -Wed Nov 30 04:31:18 1994 Tom Lord (lord@x1.cygnus.com) - - * *.[ch]: renamed all global identifiers to have the prefix scm_. - - * sys.c (gc_sweep, scm_mark_locations, scm_init_heap): - - Modified gc to allow objects of any multiple of sizeof(CELLPTR). - In addition, each heap segment gets to specify a freelist (which - may be shared). - - new function: scm_alloc_obj - new vars: scm_heap_table (replaces hplims) - scm_n_heap_segs (replaces (hpims_ind / 2)) - -Thu Oct 27 12:57:02 1994 Aubrey Jaffer (jaffer@jacal) - - From: Jerry D. Hedden <hedden@esdsdf.dnet.ge.com> - * ioext.c: conditional code for vms and version (3.6) of Aztec C. - * pi.scm ((e digits)): Modified 'bigpi' for slight speed - improvement. Added function to calculate digits of 'e'. - -Wed Oct 26 11:22:05 1994 Aubrey Jaffer (jaffer@jacal) - - From: Gary Houston <ghouston@actrix.gen.nz> - * scl.c (round): Now rounds as described in R4RS. - - * test.scm (test-inexact): test cases for round. - -Tue Oct 25 00:02:27 1994 Aubrey Jaffer (jaffer@jacal) - - * sys.c (grow_throw lthrow dynthrow): now pass arrays, check - for adequate growth, and clear out register windows (on sparc). - -Mon Oct 24 01:05:34 1994 Aubrey Jaffer (jaffer@jacal) - - * ioext.c (ttyname fileno): added. - -Sat Oct 22 12:12:57 1994 Aubrey Jaffer (jaffer@jacal) - - * unix.c (symlink readlink lstat): added. - - * scmfig.h repl.c sys.c (IO_EXTENSIONS): flag removed. - - * ioext.c (read-line read-line! file-position, file-set-position - reopen-file open-pipe opendir readdir rewinddir closedir chdir - umask rename-file isatty? access chmod mkdir rmdir stat utime - raise): moved from "repl.c" and "sys.c". - -Fri Oct 21 21:19:13 1994 Aubrey Jaffer (jaffer@jacal) - - From: Radey Shouman <shouman@ccwf.cc.utexas.edu> - * unif.c (ra2contig): now has a second parameter to indicate - whether copying is necessary or not. Eliminates gratuitous copy - by UNIFORM-ARRAY-READ! when called with a noncontiguous array. - - (array_map): more liberal check on when ARRAY-MAP! can use - array-ified asubrs. - -Thu Oct 20 18:00:35 1994 Aubrey Jaffer (jaffer@jacal) - - * sys.c (opendir readdir rewinddir closedir reopen-file): added - under IO_EXTENSIONS. - -Wed Oct 19 14:18:26 1994 Aubrey Jaffer (jaffer@jacal) - - * eval.c (badargsp): added under ifndef RECKLESS to check @apply - and apply() arg counts. - -Tue Oct 18 00:02:10 1994 Aubrey Jaffer (jaffer@jacal) - - * unix.c (mknod acct nice sync): added. - - * socket.c (socket bind! gethost connect! listen! accept): added. - - * time.c (utime): added under IO_EXTENSIONS. - -Mon Oct 17 23:49:06 1994 Aubrey Jaffer (jaffer@jacal) - - * sys.c (getcwd umask access chmod mkdir rmdir): added - under IO_EXTENSIONS. - - * scm.c (l_pause): added if SIGALRM defined. - (l_sleep): added if SIGALRM not defined. - - * scl.c (num2ulong): added. Used in "time.c" - -Sun Oct 16 22:41:04 1994 Aubrey Jaffer (jaffer@jacal) - - * sys.c (access chmod): Posix access added under IO_EXTENSIONS. - -Fri Oct 14 09:45:32 1994 Aubrey Jaffer (jaffer@jacal) - - * posix.c (chown link pipe waitpid, kill, getpw, getgr, get*id, - set*id): added. - - * time.c (l_raise l_getpid): added - * subr.c (ulong2big): - * scl.c (ulong2num): useful routines for system call data - conversion moved from "time.c". - -Thu Sep 22 14:48:16 1994 Aubrey Jaffer (jaffer@jacal) - - * subr.c (big2inum): (more accruately) renamed from big2long. - -Tue Sep 6 22:22:16 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@hpcf.cc.utexas.edu (Radey Shouman) - Date: Mon, 29 Aug 1994 11:36:46 +0600 - * unif.c: This is a large patch, but also a bit larger than it - appears -- I moved a few function definitions around to eliminate - gratuitous forward references. - - * unif.c repl.c (raprin1): Combined print routine for arrays with - that for uves. - - * unif.c (UNIFORM-VECTOR-READ! and -WRITE): work with general - arrays, by copying when necessary, renamed them to - UNIFORM-ARRAY-READ! and -WRITE. - - * unif.c (ARRAY-CONTENTS): Generalized so that it returns a 1-d - array even when the stride in the last dimension is greater than - one, gave it an optional second argument STRICT, which makes it - behave as it did before, returning an array/vector only if the - contents are contiguous in memory. - - * unif.c (ARRAY-CONTIGUOUS?) Eliminated. Instead, use - (lambda (ra) (array? (array-contents ra #t))) - - * unif.c code.doc (ramapc): unrolls arrays mapping into one loop - if possible, to make this quick, changed the format of the array - CAR, now uses one bit to indicate that an array is contiguous -- - this still allows a ridiculous number of dimensions. - - * scm.h (DSUBRF): dsubrs are mapped directly, to allow this I - moved the typedef for dsubr and #define for DSUBRF to scm.h - - * unif.c (ARRAY-MAP!) taught something about subrs, now most subrs - may be mapped without going through apply(), saving time and - reducing consing. +, -, *, /, =, <, <=, >, and >= are mapped - directly as special cases -- for uniform arrays this is nearly as - fast as the equivalent C, and doesnt' cons. I've made sure that - +, -, *, and / vectorize on the CRAY, this may be wasted effort - but the effort is not great. - - * unif.c (ARRAY-COPY!) now copies many arrays of differing types - to each other without going through the aref/aset, e.g. float -> - double, double -> complex, integer -> float ... This should make - array type coercions for arithmetic faster. - - * unif.c (TRANSPOSE-ARRAY) Added, which returns a shared array - that is the transpose of its first argument. I think this does - what an APL:TRANSPOSE would. - - * unif.c (ENCLOSE-ARRAY) Added, this returns an array that looks - like an array of shared arrays, the difference being that the - shared arrays are not actually allocated until referenced. - Internally, the contents of an enclosed array is another array. - The main reason for this is to allow a reasonably efficient - implementation of APL:COMPRESS, EXPAND, and INDEXING. In order to - actually make an array of shared arrays, just use ARRAY-COPY!. - - * unif.c (cvref): Created internal version of aref(), cvref() that - doesn't do error checking; Thus speeding things up. Profiling of - SCM running array code revealed that aref() was taking a - surprising fraction of the CPU time - - TO DO: - - The mechanism for looking up the vectorized functions is a little - kludgy, I was tempted to steal some of the CAR of the subr type to - encode an offset into a table of vectorized functions, but this - would make it more likely that dynamically loaded subrs lose thier - names. - - It is almost possible to write APL:+ and friends now, it is just - necessary to figure out the appropriate type of the returned array - and allocate it, and to promote scalar arguments to arrays (with - increments 0). - - This doesn't include vectorized REAL-PART, IMAG-PART, - MAKE-RECTANGULAR ... - - I think some C support for APL:REDUCE and maybe INNER-PRODUCT will - be needed for a reasonably fast APL.scm - - unif.c is getting quite big, time to split it up? - - -Mon Sep 5 22:44:50 1994 Aubrey Jaffer (jaffer@jacal) - - * Init.scm repl.c (quit): code was not using return values - correctly. - -Sun Aug 21 01:02:48 1994 Aubrey Jaffer (jaffer@jacal) - - * record.c (init_record): remaining record functions moved into C - code. - * eval.c sys.c: compiled closures now conditional under CCLO. - -Sat Aug 20 23:03:36 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * eval.c (ceval apply): - * sys.c (makcclo): tc7_cclo, compiled closures, now supported. - * record.c (init_record): C implementation of slib "Record"s using - CCLO. - * scm.h subr.c (QUOTIENT MODULO REMAINDER): fixes a bug for - bignums with DIGSTOOBIG defined. Also, changed the return type of - longdigs() to void, since that value is no longer used anywhere. - -Mon Aug 1 11:16:56 1994 Aubrey Jaffer (jaffer@jacal) - - * time.c (curtime): replaces get-universal-time. Other time - functions removed (SLIB support more complete). - - * subr.c (divbigbig): fixed (modulo -2177452800 86400) => 86400 - bug. Also added to test.scm. - -Sun Jul 24 16:09:48 1994 Aubrey Jaffer (jaffer@jacal) - - * dynl.c (init_dynl): *feature* dld:dyncm added for dynamically - (ldso) linked libc.sa and libm.sa (under Linux). - -Fri Jul 15 12:53:48 1994 Aubrey Jaffer (jaffer@jacal) - - * unif.c (array-fill!): bug with increment in default clause fixed. - Fast string support added. - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c (array-fill! array-for-each): bug fixes. - -Sun Jul 10 01:51:00 1994 Aubrey Jaffer (jaffer@jacal) - - * scm.c (run_scm init_scm): "-a" heap allocation argument supported. - - * Makefile (proto.h): removed. - - From: Drew Whitehouse, Drew.Whitehouse@anu.edu.au - * scm.h (P): Conditionalized ANSI'fied version of the scm.h. - -Sun Jun 26 12:41:59 1994 Aubrey Jaffer (jaffer@jacal) - - * Link.scm (usr:lib lib): Now checks for shared libraries - (lib*.sa) first. - -Thu Jun 23 19:45:53 1994 Aubrey Jaffer (jaffer@jacal) - - * scl.c scm.c: Support for compilation under Turbo C++ for Windows - (system and exec disabled) added under C flag "_Windows". - -Sat Jun 18 11:47:17 1994 Aubrey Jaffer (jaffer@jacal) - - * test.scm ((test-delay)): added. - ((test-bignum)): added and called automatically if bignums - suported. test-inexact called automatically if inexacts - supported. - -Mon Jun 6 09:26:35 1994 Aubrey Jaffer (jaffer@jacal) - - * Init.scm (trace untrace): moved to SLIB/trace.scm. - -Thu May 12 00:01:20 1994 Aubrey Jaffer (jaffer@jacal) - - * Link.scm: Autoload for hobbit now does (provide 'hobbit). This - allows hobbit to know if it is self compiling (although reloads of - hobbit will not be quite right). - ((compile file . args)): removed. - - * makefile.unix (proto.h): removed. - - * Transcen.scm: compile-allnumbers HOBBIT declaration added. - Init.scm will now load compiled Transcen.o. - - * scm.h: HOBBIT section removed. - - * README (SLIB): Now strongly recommends getting SLIB and lists - ftp sites. - - * eval.c (m_delay): fixed bug with multiple sets of (delay x). - -Thu Apr 28 22:41:41 1994 Aubrey Jaffer (jaffer@jacal) - - * unif.c (makflo): shortcut for single precision float arrays - added. - -Fri Apr 15 00:54:14 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c: no longer uses pointer comparisons in loops. Should - fix problems on 8086 processors. - * unif.c (make_sh_array): Fixes MAKE-SHARED-ARRAY so that shared - arrays with only 1 element in some direction may still be - ARRAY-CONTIGUOUS? - (uve_write uve_read): Fixes bug in UNIFORM-ARRAY-WRITE, - UNIFORM-ARRAY_READ!. Now they do the right thing for shared - bit-arrays not starting at the beginning of their contents vector. - (array_contents ARRAY-SIMPLE?): ARRAY-CONTENTS may now return a - shared, contiguous, 1-d array, instead of a vector, if the array - cannot access all of the contents vector. ARRAY-SIMPLE? removed. - (array-fill!): a replacement and generalization of - UNIFORM-VECTOR-FILL!. - (raequal): Combines with uve_equal(), providing also ARRAY-EQUAL? - ARRAY-EQUAL? is equivalent to EQUAL? if all its arguments are - uniform vectors or if all are arrays. It differs from EQUAL? in - that a shared, 1-d array may be ARRAY-EQUAL? to a uniform vector. - for example - (define sh (make-shared-array '#(0 1 2 3) list '(0 1))) ==> #1(0 1) - (equal? '#(0 1) sh) ==> #F - (array-equal? '#(0 1) sh) ==> #T - (list2ura): Combines list2uve() and list2ura(). - -Thu Apr 14 23:26:54 1994 Aubrey Jaffer (jaffer@jacal) - - * time.c (LACK_FTIME LACK_TIMES): defined for vms. - -Mon Apr 4 10:39:47 1994 Aubrey Jaffer (jaffer@jacal) - - * eval.c (copytree): now copies vectors as well. - - * repl.c (quit): now accepts #t and #f values. - -Sun Apr 3 23:30:14 1994 Aubrey Jaffer (jaffer@jacal) - - * repl.c (repl): call to my_time() moved to not include READ time. - - * time.c (mytime): now prefers to use times() over clock(). - Compilation constant CLOCKS_PER_SEC doesn't scale when a binary is - moved between machines. - -Thu Mar 31 16:22:53 1994 Aubrey Jaffer (jaffer@jacal) - - * Init.scm (*SCM-VERSION*): added. - - * Makefile (intro): Added message for those who just make. - Cleaned up and reorganized Makefile. - - * patchlvl.h (PATCHLEVEL): removed. Whole version now just in - SCMVERSION. - -Wed Mar 23 00:09:51 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * repl.c (iprin1): Characters higher than 127 print as - #\<octal-number>. - - * Init.scm ((read:array digit port)): added. Most # syntax - handled in read:sharp. - - * unif.c (clist2uve clist2array): removed. - -Fri Mar 11 15:10:53 1994 Radey Shouman (rshouman@chpc.utexas.edu) - - * sys.c (sfgetc): can now return EOF. - -Mon Mar 7 17:07:26 1994 Aubrey Jaffer (jaffer@jacal) - - * patchlvl.h (SCMVERSION): 4e0 - - * scmfig.h: was config.h (too generic). - - * scm.c (main run_scm) repl.c (repl_driver init_init): now take - initpath argument. IMPLINIT now used in scm.c - -Sun Feb 27 00:27:45 1994 Aubrey Jaffer (jaffer@jacal) - - * eval.c (ceval m_cont IM_CONT): @call-with-current-continuation - special form for tail recursive call-with-current-continuation - added. call_cc() routine removed. - -Fri Feb 25 01:55:06 1994 Aubrey Jaffer (jaffer@jacal) - - * eval.c (ceval m_apply IM_APPLY apply:nconc-to-last): @apply - special form for tail-recursive apply added. ISYMs reactivated. - -Mon Feb 21 14:42:12 1994 Aubrey Jaffer (jaffer@jacal) - - * crs.c (nodelay): added. In NODELAY mode WGETCH returns - eof-object when no input is ready. - - * Init.scm ((read:sharp c port)): defined to handle #', #+, and - #-. - - * repl.c (lreadr): Now calls out to Scheme function read:sharp - when encountering unknown #<char>. - -Tue Feb 15 01:08:10 1994 Aubrey Jaffer (jaffer@jacal) - - From: Shiro KAWAI <kawai@sail.t.u-tokyo.ac.jp> - * eval.c (ceval apply): under flag CAUTIOUS, checks for applying - to non-lists added. - -Sat Feb 12 21:23:01 1994 Aubrey Jaffer (jaffer@jacal) - - * sys.c (sym2vcell intern sysintern): now use internal strhash(). - - * scl.c sys.c (hash hashv hashq strhash()): added. - -Sat Feb 5 01:24:35 1994 Aubrey Jaffer (jaffer@jacal) - - * scm.h (ARRAY_NDIM): #define ARRAY_NDIM NUMDIGS changed to - #define ARRAY_NDIM(x) NUMDIGS(x) to correct problem on Next. - -Fri Feb 4 23:15:21 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c: 0d arrays added. Serial array mapping functions and - ARRAY-SIMPLE? added. - -Thu Feb 3 12:42:18 1994 Aubrey Jaffer (jaffer@jacal) - - * scm.h (LENGTH): now does unsigned shift. - -Wed Feb 2 23:40:25 1994 Aubrey Jaffer (jaffer@jacal) - - * Link.scm (*catalog*): catalog entries for db (wb), - turtle-graphics, curses, regex, rev2-procedures, and - rev3-procedures added. - -Sun Jan 30 19:25:24 1994 Aubrey Jaffer (jaffer@jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * sys.c eval.c setjump.h setjump.s (longjump setjump): full - continuations now work on Cray YMP. - -Thu Jan 27 01:09:13 1994 Aubrey Jaffer (jaffer@jacal) - - * dynl.c MANUAL Init.scm (init_dynl): dynamic linking modified for - modern linux. - -Sat Jan 22 17:58:55 1994 Aubrey Jaffer (jaffer@jacal) - - From: ucs3028@aberdeen.ac.uk (Al Slater) - * makefile.acorn repl.c (set_erase): Port to acorn archimedes. - This uses Huw Rogers free unix function call library for the - archimedes - this is very very widely available and should pose no - problem to anyone trying to find it - its on every archimedes ftp - site. - - From: hugh@cosc.canterbury.ac.nz (Hugh Emberson) - * dynl.c Link.scm: Dynamic Linking with SunOS. - -Thu Jan 6 22:12:51 1994 (jaffer at jacal) - - * sys.c (gc_mark mark_locations): now externally callable. - -Sun Jan 2 19:32:59 1994 (jaffer at jacal) - - From: fred@sce.carleton.ca (Fred J Kaudel) - * unif.c (ra_matchp ramapc): patch to unif.c avoids two problems - (K&R C does not allow initialization of "automatic" arrays or - structures). This was not use in 4d2 or previously, and the - following patch ensures that such initialization only occurs for - ANSI C compilers (Note that K&R C compilers need to explicitly - assign the values). - -Sat Dec 18 23:55:30 1993 (jaffer at jacal) - - * scm.1 scm.doc (FEATURES): improved and updated manual page. - - * repl.c (BRACKETS_AS_PARENS): controls whether [ and ] are read - as ( and ) in forms. - -Wed Dec 8 23:13:09 1993 (jaffer at jacal) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c: More array fixes and functions. - -Tue Dec 7 00:44:23 1993 (jaffer at jacal) - - * dynl.c (dld_stub): removed since dld is working better on Linux. - -Wed Dec 1 15:27:44 1993 (jaffer at jacal) - - * scm.h (SNAME): explicit cast added to get rid of compiler - warnings. - - From: bh@anarres.CS.Berkeley.EDU (Brian Harvey) - * repl.c (repl) output newlines when more than one form on a line - for Borland C. - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c: More array fixes and documentation. - -Mon Nov 29 01:06:21 1993 Aubrey Jaffer (jaffer at montreux) - - From: rshouman@chpc.utexas.edu (Radey Shouman) - * unif.c: More array functions (need documentation). - -Sun Nov 28 01:34:22 1993 (jaffer at jacal) - - * scm.h (SNAME): returns a pointer to nullstr if offset is 0. - - * subr.c eval.c (make_synt make_subr): now check that offset from - heap_org hack works for each subr. If not, 0 is used. - - * Link.scm (compile-file): compiles SCM file to object suitable - for LOAD. - - * Link.scm: initialization file created with Scheme code for - compilation and linking. LOAD now automatically loads SCM object - files. - - * dynl.c Init.scm: dynamic linking now works under DLD on Linux. - Wb, crs, and sc2 can by dynamically loaded. - -Thu Nov 25 22:58:36 1993 (jaffer at jacal) - - * sys.c (ltmpnam): return value of mktemp call tested in accord - with HP-UX documentation (returns "" on error). - - * config.h (SYSCALLDEF): removed. Macro I/O calls (getc, putc) - replaced with function versions. Control-C interrupts should work - while pending input on all systems again. - -Tue Nov 23 01:18:35 1993 (jaffer at jacal) - - From: dorai@cs.rice.edu (Dorai Sitaram) - * repl.c sys.c time.c config.h: MWC (Mark Williams C) support. - -Sun Nov 7 10:58:53 1993 (jaffer at jacal) - - From: "Greg Wilson" <Greg.Wilson@cs.anu.edu.au> - * scm.c config.h (TICKS ticks tick-interrupt): if TICKS is - #defined, ticks and tick-interrupt work like alarm and - alarm-interrupt, but with units of evaluation rather than units of - time. - -Mon Nov 1 18:47:04 1993 (jaffer at jacal) - - * unif.c (uniform-vector-ref => array-ref): integrated arrays - with uniform-vectors. Strings, vectors, and uniform-vectors - now just special case of arrays (to the user). - -Fri Oct 29 01:26:53 1993 (jaffer at jacal) - - * unif.c (rasmob tc16_array): arrays are now a smob. - -Thu Oct 28 01:21:43 1993 (jaffer at jacal) - - * sys.c repl.c (igc gc_start): GC message gives reason for GC. - -Wed Oct 27 10:03:00 1993 (jaffer at jacal) - - * config.h (SICP): flag makes (eq? '() '#f) and changes other - things in order to make SCM more compatible with Abelson and - Sussman's book. - - * sys.c (gc_mark gc_sweep mark_locations): GC bug fixed. GC from - must_malloc would collect the tc_free_cell already allocated. - - * sys.c setjump.h (must_malloc must_realloc INIT_MALLOC_LIMIT): - modified to call igc when malloc usage exceeds mtrigger (idea from - hugh@ear.MIT.EDU, Hugh Secker-Walker). - - From: Jerry D. Hedden - * pi.scm (bigpi): bignum version of pi calculator. - -Tue Oct 26 18:41:33 1993 (jaffer at jacal) - - * repl.c (room): added procedure for printing storage statistics. - -Sun Oct 24 22:40:15 1993 (jaffer at jacal) - - * config.h eval.c scl.c (STACK_LIMIT CHECK_STACK): added. - * sys.c (stack_check): added. - -Sat Oct 23 00:08:30 1993 (jaffer at jacal) - - * sys.c (mallocated): added to keep track of non-heap usage. - - * sys.c (igc): fixed interrupt vulnerabilities around gc. - -Sun Oct 17 13:06:11 1993 (jaffer at jacal) - - * repl.c (exit_report): added. Prints cumulative times if - (verbose > 2). Called from free_storage(). - - * repl.c (repl): fixed CRDYP(stdin) BUG! Transcripts should work - again. Other annoying CR behaviour fixed. - - * time.c (init_time your_base my_base): now not reset when - restarting so timing numbers for restarting are correct. - - * scm.h (sys_protects): rearranged. - * sys.c (tmp_errp): now a statically allocated global variable, - used by init_storage and free_storage. - * scm.h sys.c (tc16_fport, tc16_pupe, tc16_strport, tc16_sfport): - now #defines (which must correspond to order of newptob calls). - -Sun Oct 3 20:38:09 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie) - - * README.unix configure configure.in scmconfig.h.in - mkinstalldirs Makefile.in acconfig-1.5.h: SCM can now be built - using GNU autoconf. Put in scmconfig4c5.tar.gz - -Sun Oct 3 00:33:57 1993 (jaffer at jacal) - - * MANUAL (bit-count bit-position bit-set*! bit-count* - bit-invert!): (from unif.c) are now documented. - - * sys.c (fixconfig): added 3rd argument to distinguish between - setjump.h and config.h. - * setjump.h config.h: moved IN_SYS stuff from config.h to - setjump.h. - * config.h (HAVE_CONFIG_H): User config preferences now taken - from "scmconfig.h" if HAVE_CONFIG_H is defined. - * config.h (EXIT_SUCCESS EXIT_FAILURE): fixed for VMS. - -Sat Oct 2 00:34:38 1993 (jaffer at jacal) - - From: rshouman@hermes.chpc.utexas.edu (Radey Shouman) - * unif.c repl.c: added read and write syntax for uniform vectors. - * unif.c (uniform-vector->list list->uniform-vector): created. - * time.c (time_in_msec): conditionalized for wide range of CLKTCK - values. - * config.h (BITSPERDIG POINTERS_MUNGED) - * scm.h (PTR2SCM SCM2PTR) - * scl.c (DIGSTOOBIG) - Ported SCM to Unicos, the Cray operating system. - - From: schwab@ls5.informatik.uni-dortmund.de (Andreas Schwab) - * scl.c (dblprec): set from DBL_DIG, if available. - -Fri Oct 1 21:43:58 1993 (jaffer at jacal) - - * unif.c (bit-position): now returns #f when item is not found. - Now returns #f when 3rd argument is length of 2nd argument - (instead of error). - -Fri Sep 24 14:30:47 1993 (jaffer at jacal) - - * sys.c (free_storage): fixed bug where growth_mon was being - called after the port cell had been freed. gc_end now also - called at end. - -Tue Sep 21 23:46:05 1993 (jaffer at jacal) - - * Init.scm scm.c: Restored old command line behaviour (loading all - command line arguments) for case when first command line argument - does not have leading `-'. - - * sys.c (mode_bits): abstracted from open_file and mksfpt. - - * scm.h (*FPORTP): series of predicates added for operations which - only work on some fports. - - * sys.c crs.c: ungetc removed from ptobfuns structure and - soft-ports. - -Mon Sep 20 23:53:25 1993 (jaffer at jacal) - - * sys.c (make-soft-port): Soft-ports added, allowing Scheme - i/o extensions. - -Sun Sep 19 22:55:28 1993 (jaffer at jacal) - - * 4c4: released. - * Init.scm scm.c scm.1: command line proccessing totally - rewritten. Thanks to Scott Schwartz - <schwartz@groucho.cs.psu.edu> for help with this. - -Mon Sep 13 21:45:52 1993 (jaffer at jacal) - - From: pegelow@moorea.uni-muenster.de (Ulrich Pegelow) - * scl.c (add1): finally a way to fool optimizing gcc to not use - extra precision registers. - -Sun Sep 12 18:46:02 1993 (jaffer at jacal) - - * sys.c (pwrite): added to stubbify fwrite to fix bug on VMS. - * config.h: moved flags to top per suggestions from Bryan - O'Sullivan (bos@scrg.cs.tcd.ie). - -Fri Sep 10 11:42:27 1993 (jaffer at jacal) - - * repl.c config.h (EXIT_SUCCESS EXIT_ERROR): added. Values - returned by SCM program. - -Thu Sep 9 13:09:28 1993 Aubrey Jaffer (jaffer at camelot) - - From: Vincent Manis <manis@cs.ubc.ca> - * sys.c (stwrite init_types add_final): fixed declarations. - -Mon Sep 6 16:10:50 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie) - - * README: changed the build and installation instructions to bring - them up to date with reality. - -Sun Sep 5 23:08:54 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie) - - * Wrote autoconf script to support GNU Autoconf configuration - to make scm easier to build. - - * Created Makefile.in; a radical overhaul of Makefile to remove - some of the brokenness and allow cross-compilation and use of - autoconf. - -Sat Sep 4 23:00:49 1993 (jaffer at jacal) - - * 4c3: released. - * sys.c (grow_throw): removed use of memset for SPARC machines. - -Sat Sep 4 18:09:59 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie) - - * time.c: added SVR4 to the list of LACK_FTIME systems, because - most all SVR4 BSD-compatibility stuff is a total mess. - - * config.h: changed definition of STDC_HEADERS so it does the - Right Thing on systems which run GCC but don't have header files - with prototypes. - - * makefile.unix: added a note for SVR4 users. - -Tue Aug 31 18:30:53 1993 (jaffer at jacal) - - * eval.c (m_define): if verbose >= 5 warnings are issued for all - top-level redefinitions. - -Mon Aug 30 16:24:26 1993 (jaffer at jacal) - - * scm.c sys.c (finals num_finals add_final): Finalization calls - now dynamically, incrementally, defined. - -Thu Aug 26 12:38:27 1993 Aubrey Jaffer (jaffer at camelot) - - * 4c2: fixed declaration problems in PTOB with K&R C. - -Sun Aug 22 23:02:51 1993 (jaffer at jacal) - - * split.scm: code which directs input, output, and diagnostic - output to separate windows (using curses functions defined in - crs.c). - -Sat Aug 21 16:46:33 1993 (jaffer at jacal) - - * Init.scm (output-port-height): added if not already defined. - output-port-width also made conditional. - - * sys.c (tc16_strport): string ports created. - -Thu Aug 19 11:37:07 1993 (jaffer at jacal) - - * sys.c (init_types): freecell, floats, and bignums now have SMOB - entries. gc_sweep and gc_mark still inline codes for bignums and - floats. - - * sys.c repl.c code.doc: Ports now an extensible type. - Indirection suggested by Shen <sls@aero.org>. - -Mon Aug 16 01:20:26 1993 (jaffer at jacal) - - * crs.c: curses support created. - -Sun Aug 15 16:56:36 1993 (jaffer at jacal) - - * rgx.c sys.c (mark0 equal0): mark0 moved to sys.c. equal0 - created. - -Fri Jun 25 01:16:31 1993 (jaffer at jacal) - - * QUICKREF: added. - -Tue Jun 22 00:40:58 1993 Aubrey Jaffer (jaffer at camelot) - - * repl.c (ungetted): replaced with CRDYP(stdin) to fix recently - introduced transcript bug. - -Sun Jun 20 22:29:32 1993 Aubrey Jaffer (jaffer at camelot) - - * config.h (NOSETBUF): setbuf() now conditionalized on NOSETBUF. - - * Init.scm (defmacro): now copies the results of macro expansion - in order to avoid capture of memoized code by macros like: - (defmacro f (x) `(list '= ',x ,x)). - -Wed Jun 2 23:32:05 1993 Aubrey Jaffer (jaffer at caddr) - - * eval.c (map for-each): now check that arguments are lists. - -Mon May 31 23:05:19 1993 Aubrey Jaffer (jaffer at camelot) - - * Init.scm (trace untrace): now defmacros which handle (trace) and - (untrace) as in Common Lisp. - -Wed May 5 01:17:37 1993 Aubrey Jaffer (jaffer at camelot) - - From: Roland Orre <orre@sans.kth.se> - * all: internal output functions now take SCM ports instead of - FILE* in preparation for string-ports. - -Tue May 4 17:49:49 1993 Aubrey Jaffer (jaffer at wbtree) - - * makefile.unix (escm.a): created scm "ar" file and used for - dbscm. - -Sun Apr 25 21:35:46 1993 Aubrey Jaffer (jaffer at camelot) - - * sys.c (free_storage): i++ moved out of CELL_* in response to: -From: john kozak <jkozak@cix.compulink.co.uk> -Minor bug report: around line 10 of routine "free_storage" you do calls -to CELL_UP and CELL_DOWN with arguments having side-effects: with the -PROT386switch defined in config.h these args are evaluated twice... - -Sun Apr 11 22:56:19 1993 Aubrey Jaffer (jaffer at camelot) - - * eval.c (IM_DEFINE): added. Internal defines are no longer - turned into LETRECS. - -Wed Apr 7 13:32:53 1993 Aubrey Jaffer (jaffer at camelot) - - Jerry D. Hedden <HEDDEN@ESDSDF.dnet.ge.com> - * scl.c (idbl2str): fix for bug introduced by removing +'s. - -Tue Mar 23 15:37:12 1993 Aubrey Jaffer (jaffer at camelot) - - * scl.c (idbl2str): now prints positivie infinity as +#.# again - (instead of #.#). - -Mon Mar 22 01:38:02 1993 Aubrey Jaffer (jaffer at montreux) - - * subr.c (quotient): renamed to lquotient to avoid conflict with - HP-UX 9.01. - -Fri Mar 19 01:21:08 1993 Aubrey Jaffer (jaffer at camelot) - - * sys.c repl.c: #ifndef THINK_C #include <sys/ioctl.h> - * time.c (lstat): #ifndef THINK_C. ThinkC 5.0.1 lacked. - -Mon Mar 15 23:35:32 1993 Aubrey Jaffer (jaffer at camelot) - - From: jhowland@ariel.cs.trinity.edu (Dr. John E. Howland) - * scl.c (idbl2str iflo2str big2str): leading + eliminated on - output and number->string. - -Wed Mar 10 00:58:32 1993 Aubrey Jaffer (jaffer at camelot) - - * repl.c scm.h (CRDYP CLRDY CGETUN CUNGET): cleaned up ungetc hack. - - * scm.c repl.c (exec): added. - -Sun Mar 7 22:44:23 1993 Aubrey Jaffer (jaffer at camelot) - - * repl.c (def_err_response): now will print errobjs if they are - immediates, symbols, ports, procedures, or numbers. - -Fri Mar 5 23:15:54 1993 Aubrey Jaffer (jaffer at camelot) - - * repl.c (repl): now gives repl_report() for initialization. - - * Init.scm (defvar): added. - - From: Roland Orre <orre@sans.kth.se> - * repl.c (lungetc): no longer calls ungetc. Fixed problem that - many systems had with ungetc on unbuffered ports (setbuf(0)). - -Thu Mar 4 13:51:12 1993 Aubrey Jaffer (jaffer at camelot) - - From: Stephen Schissler - * makefile.wcc: Watcom support added. - -Wed Mar 3 23:11:08 1993 Aubrey Jaffer (jaffer at montreux) - - * sys.c scm.h (dynwinds): made a sys_protect. - -Mon Feb 15 11:30:50 1993 Aubrey Jaffer (jaffer at camelot) - - * Init.scm (defmacro macroexpand macroexpand1 macro? gensym): - added. - - * repl.c (stdin): setbuf not done for __TURBOC__==1. - - * makefile.bor: now has method to build turtegr.exe. - - * eval.c (ceval): Memoizing macros now can return any legal Scheme - expression. - -Sat Feb 13 18:01:13 1993 Aubrey Jaffer (jaffer at camelot) - - * subr.c (mkbig adjbig): now check for bignum size. - - * Init.scm: reorganized so site-specific information is at the - head. - - * repl.c (errno): changed from set-errno now returns value. - - * subr.c (intexpt): now handles bignum exponents. - - From: "David J. Fiander" <davidf@golem.waterloo.on.ca> - * time.c makefile.unix subr.c: SCO Unix and XENIX patches. - -Fri Feb 12 22:18:57 1993 Aubrey Jaffer (jaffer at camelot) - - * Init.scm (WITH-INPUT-FROM-PORT WITH-OUTPUT-TO-PORT - WITH-ERROR-TO-PORT): added. - - * subr.c (ash): fixed for case (ash 2 40) where INUM arguments - make a bignum result. - - * repl.c (lreadr): \ followed by a newline in a string is ignored. - - From: Scott Schwartz <schwartz@groucho.cs.psu.edu> - * repl.c (lreadr): Can now read \0\f\n\r\t\a\v in strings. - -Thu Feb 11 01:25:50 1993 Aubrey Jaffer (jaffer at camelot) - - * Init.scm (with-input-from-file with-output-to-file - with-error-to-file): now use dynamic-wind. - -Sun Feb 7 22:51:08 1993 Aubrey Jaffer (jaffer at camelot) - - * eval.c (ceval): fixed bug with non-memoizing macro returning an - IMP. - -Sat Feb 6 01:22:27 1993 Aubrey Jaffer (jaffer at camelot) - - * (current-error-port with-error-to-file): add. - -Fri Feb 5 00:51:23 1993 Aubrey Jaffer (jaffer at camelot) - - * time.c (stat): added. - - From: rnelson@wsuaix.csc.wsu.edu (roger nelson) - * dmakefile: support for DICE C on Amiga. - -Thu Feb 4 01:55:30 1993 Aubrey Jaffer (jaffer at camelot) - - * sys.c (open-file) makes unbuffered if isatty. - - * repl.c (char-ready?) added. - -Mon Feb 1 15:24:18 1993 Aubrey Jaffer (jaffer at camelot) - - * subr.c (logor): changed to LOGIOR to be compatible with common - Lisp. - - * eval.c (bodycheck): now checks for empty bodies. - -Sun Jan 31 01:01:11 1993 Aubrey Jaffer (jaffer at camelot) - - * time.c (get-universal-time decode-universal-time): now use - bignums. - -Tue Jan 26 00:17:06 1993 Aubrey Jaffer (jaffer at camelot) - - * sys.c (mark_locations): now length argument in terms of - STACKITEM. Does both alignments in one pass. - -Mon Jan 25 12:13:40 1993 Aubrey Jaffer (jaffer at camelot) - - From: soravi@Athena.MIT.EDU - * makefile.emx: for OS/2 - -Sun Jan 24 18:46:32 1993 Aubrey Jaffer (jaffer at camelot) - - From: stevev@miser.uoregon.edu (Steve VanDevender) - * scl.c (big2str): now faster because it divides by as many 10s as - fit in a BIGDIG. - -Sat Jan 23 00:23:53 1993 Aubrey Jaffer (jaffer at camelot) - - From: stevev@miser.uoregon.edu (Steve VanDevender): - * config.h (INUM MAKINUM): shift optimization for TURBOC. - -Fri Jan 22 00:46:58 1993 Aubrey Jaffer (jaffer at montreux) - - From: hanche@ams.sunysb.edu (Harald Hanche-Olsen) - * unif.c (uniform-vector?): added. - -Tue Jan 19 00:27:04 1993 Aubrey Jaffer (jaffer at camelot) - - From: stevev@miser.uoregon.edu (Steve VanDevender) - * subr.c scl.c config.h: bignum bug fixes for MSDOS. - -Mon Jan 18 01:15:24 1993 Aubrey Jaffer (jaffer at camelot) - - * subr.c (ash lognot intlength logcount bitextract): now handle - bignums. - -Sun Jan 17 10:42:44 1993 Aubrey Jaffer (jaffer at camelot) - - * sys.c (close_port): can now close pipes as well. - - * subr.c (adjbig normbig divide quotient): fixed more divide bugs. - - * subr.c (even? odd?): fixed problem with bignums. - -Sat Jan 16 00:02:05 1993 Aubrey Jaffer (jaffer at camelot) - - * subr.c (divbigbig): Fixed last divide bug? - -Fri Jan 15 00:07:27 1993 Aubrey Jaffer (jaffer at camelot) - - * rgx.c (regmatch?): added. Debugged for both HP-UX and GNU - regex-0.11. Documentation added to MANUAL. - -Thu Jan 14 11:54:52 1993 Aubrey Jaffer (jaffer at camelot) - - * patchlvl.h (SCMVERSION): moved from config.h. - - * scl.c (product): fixed missing {} bug. - - From: HEDDEN@esdsdf.dnet.ge.com - * scl.c (lmin lmax) bignum versions. - -Wed Jan 13 01:40:51 1993 Aubrey Jaffer (jaffer at camelot) - - * released scm4b0. - - * subr.c: fixed bignum bugs found by jacal. - - * code cleanup. - - From: HEDDEN@esdsdf.dnet.ge.com - * subr.c (lgcd quotent modulo lremainder): Bignum versions. - * subr.c (divbigbig): new version. - -Sun Jan 3 00:29:35 1993 Aubrey Jaffer (jaffer at camelot) - - From: stevev@miser.uoregon.edu (Steve VanDevender) - * Re-port to BorlandC v2.0 - - * sys.c (must_realloc): added - - * config.h subr.c (BIGRAD pseudolong): now insensitive to ratio of - sizeof(long)/sizeof(BIGDIG). - -Mon Dec 21 23:20:47 1992 Aubrey Jaffer (jaffer at camelot) - - From: Scott Schwartz <schwartz@groucho.cs.psu.edu> - * rgx.c: created SCM interface to regex and regexp routines. - - From: HEDDEN@esdsdf.dnet.ge.com - * subr.c scl.c: Now just one mulbigbig and addbigbig routine. - - from: soravi@Athena.MIT.EDU - * README: directions for compiling SCM under OS/2 2.0. - -Wed Dec 9 15:34:30 1992 Aubrey Jaffer (jaffer at camelot) - - * eval.c (tc7_subr_2x): eliminated. All comparison subrs now - rpsubrs. - - * scm.h: Changed SUBR numbers. This improves HP-UX interpretation - speed (why?). - - * eval.c (PURE_FUNCTIONAL): removed. Can now be done in - initialization code. - - * eval.c (tc7_rpsubr): added type for transitive comparison - operators. Suprisingly, this slows down (pi 100 5). - -Mon Dec 7 16:15:47 1992 Aubrey Jaffer (jaffer at camelot) - - * subr.c (logand logor logxor lognot ash logcount integer-length - bit-extract): added. - - From: HEDDEN@esdsdf.dnet.ge.com - * scl.c: lots more numeric improvements and code reductions. - -Mon Nov 30 12:25:54 1992 Aubrey Jaffer (jaffer at camelot) - - * scm.h (IDINC ICDR IDIST): enlarged depth count in ILOCs. - -Sun Nov 29 01:10:18 1992 Aubrey Jaffer (jaffer at camelot) - - * subr.c scl.c: most arithmetic operations will now return - bignums. - - * config.h (FIXABLE POSFIXABLE NEGFIXABLE): added. - - * sys.c (object-hash object-unhash): now use bignums. - - * scl.c (big2str istr2int): bignum i/o implemented. - - * unif.c: subr2s were incorrectly initialized as lsubr2s. - -Tue Nov 24 14:02:52 1992 Aubrey Jaffer (jaffer at camelot) - - * eval.c (ceval): added unmemocar calls to error handling when - possible. - - * scl.c (idbl2str): added back NAN and infinity support. - - * eval.c (syntax_mem): replaced with individual macros. - * eval.c (procedure->syntax procedure->macro - procedure->memoizing-macro): All syntactic keywords are now - tc7_symbol. User definable macros added. - * sys.c: ISYMs no longer in symhash. ISYMs cannot be read. - init_isyms merged into init_eval. - -Sat Nov 21 00:39:31 1992 Aubrey Jaffer (jaffer at camelot) - - * makefile.unix (check): now exits with error code. - - * sys.c (init_isyms): eliminated. ISYMS now inited in init_eval. - -Fri Nov 20 16:14:06 1992 Aubrey Jaffer (jaffer at camelot) - - * released scm4a13 - - * repl.c: longjmps now dowinds() first. - - * setjump.h: now has all setjmp related definitions. - - * Init.scm (trace untrace): use new macro system. - - * eval.c (defined? procedure->macro procedure->memoizing-macro - make_synt): macro system added. defined? uses it. - - From: HEDDEN@esdsdf.dnet.ge.com - * scl.c: fixes for several transcendental functions. - -Thu Nov 19 01:14:38 1992 Aubrey Jaffer (jaffer at camelot) - - * repl.c sys.c: errjmp replaced with JMPBUF(rootcont). - -Sun Nov 15 01:49:00 1992 Aubrey Jaffer (jaffer at camelot) - - From: HEDDEN@esdsdf.dnet.ge.com - * scl.c (istr2int istr2flo istring2number string2number): new - versions. - -Thu Nov 12 23:00:04 1992 Aubrey Jaffer (jaffer at Ivan) - - * Init.scm (load): now prints out actual filename found in mesasge - ;done loading ... - -Wed Nov 11 01:01:59 1992 Aubrey Jaffer (jaffer at camelot) - - * repl.c (def_err_response): ARG1 error with errobj==UNDEFINED - becomes WNA error. - - From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden) - * scl.c (difference divide): Now are asubrs. - - * Init.scm (*features*): fixed to correspond to SLIB conventions. - -Mon Nov 9 12:03:58 1992 Aubrey Jaffer (jaffer at camelot) - - * scl.h test.scm: (string->number "i") and "3I" and "3.3I" fixed - to return #f. Tests added to test.scm. - -Fri Nov 6 16:39:38 1992 Aubrey Jaffer (jaffer at camelot) - - * scm.h (rootcont): sysprotect added. - - From: Vincent Manis <manis@cs.ubc.ca> - * scm.h: __cplusplus prototype support. - -Thu Nov 5 00:39:50 1992 Aubrey Jaffer (jaffer at Ivan) - - * eval.c (lookupcar): now checks for UNDEFINED in local bindings - becuase LETREC inits to UNDEFINED. - - * sys.c (dynamic-wind): added. - - * config.h eval.c (ceval): CAUTIOUS mode added. - - From: hugh@ear.MIT.EDU (Hugh Secker-Walker) - * eval.c (ceval): internal defines now transformed to letrecs. - -Sun Oct 25 12:27:23 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c (read-line read-line!): created. - -Sat Oct 24 18:36:23 1992 Aubrey Jaffer (jaffer at camelot) - - * repl.c (lreadparen): now tail-recursive. - - * eval.c (copy-tree eval): added. dummy_cell replaced with a - cons(obj,UNDEFINED). - -Thu Oct 22 21:26:53 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c (set-errno!): changed to set-errno. - -Thu Oct 15 00:49:20 1992 Aubrey Jaffer (jaffer at camelot) - - * sys.c (must_free): must_free created. Pointers are set to 0. - It detects objects being freed twice. - -Wed Oct 14 23:57:43 1992 Aubrey Jaffer (jaffer at camelot) - - * scm.c (run_scm): Now has INITS and FINALS. - - * scm.c (init_signals ignore_signals unignore_signals - restore_signals): siginterrupt() for ultix. - -Fri Oct 9 14:25:06 1992 Aubrey Jaffer (jaffer at camelot) - - * all: put in explicit casts to (unsigned char *) and (long) to - satisfy lint. - - * sys.c (gc): all to gc_end was during deferred interrupts, - causing problems with verbose=3 and interrupts during GC. - - * config.h(SYSCALLDEF): fixed so that test on errno occurs before - ALLOW_INTS (and possible call to user code). - -Sun Oct 4 01:45:25 1992 Aubrey Jaffer (jaffer at camelot) - - * eval.c (syntax_mem): removed gratuitous cons. - - * eval.c repl.c scm.h: Reduced static string use. Added peephole - optimizations for AND and OR. - - From: hugh@ear.MIT.EDU (Hugh Secker-Walker) - * eval.c repl.c scm.h (syntax_mem): syntax forms are now memoized - so that syntax checks are done only once. Interpreter is now - smaller and faster and uses less stack space. Modifications to - code are now made under DEFER_INTS as they always should have - been. - -Wed Sep 30 22:06:24 1992 Aubrey Jaffer (jaffer at Ivan) - - * scl.c subr.c scm.h config.h: Started adding bignum code. - -Sun Sep 27 22:59:59 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c (restart): added. - - * sys.c (freeall): finished. - - * scm.h (tc7_symbol): split into tc7_ssymbol and tc7_msymbol to - distinguish between non-GCable and GCable symbols. - -Wed Sep 23 00:36:23 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c (peek_char lungetc): added workaround for TURBOC 1.0 - problem with ungetc inside SYSCALLDEF macro. - - * repl.c (iprin1): uses ttyname for #<stream ..> if available. - - * Init.scm: now sets verbose to 0 if stdin or stdout is not a tty. - - * repl.c (isatty?): added. - - * repl.c (verbose): levels bumped up by 1. verbose == 0 means no - prompt. - - * makefile.djg config.h (GNUDOS -> GO32): flags changed for djgpp108. - -Wed Aug 26 21:46:26 1992 Aubrey Jaffer (jaffer at Ivan) - - * test.scm: put in (test #f < 1 3 2) and (test #f >= 1 3 2). - - * scl.c (leqp greqp): put back in. (not (< 1 3 2)) does not imply - (>= 1 3 2). - - * makefile.unix: tar and shar files now created in subdirectory. - - * config.h time.c: Linux support added. - - * repl.c: Greatly improved VMS interrupt support. - - * eval.c (ceval): I_LET now changes to I_LETSTAR for single clause - unnamed lets.y - - * (tc7_lsubr_2n): removed. - -Fri Jul 31 00:24:50 1992 Aubrey Jaffer (jaffer at Ivan) - - * unif.c (bit-position): fixed; I am sure I had done these - changes before. Also corrected some error messages. - - From: campbell@redsox.bsw.com (Larry Campbell) - * scm.h subr.c sys.c (equalp): smobfuns now include equalp. - -Mon Jul 20 16:44:30 1992 Aubrey Jaffer (jaffer at Ivan) - - From: Stephen Adams <S.R.Adams@ecs.southampton.ac.uk> - * eval.c scm.h subr.c (BOOL_NOT) macro added to fix ^ bug in - BorlandC. This was fixed previously as well. - - From: campbell@redsox.bsw.com (Larry Campbell) - * unif.c (vector-set-length!): was always typing to tc7_vector. - -Sat Jul 18 01:07:33 1992 Aubrey Jaffer (jaffer at Ivan) - - * subr.c sys.c (make_vector init_storage resizuve): mallocs and - reallocs are now always > 0. - - * time.c (get_univ_time): bypassed mktime() for (__TURBOC__ == 1). - -Mon Jul 13 22:27:04 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c (lreadr): now ignores first line of port if begins with "#!" - - * scl.c (lesseqp greqp): removed; changed to use tc7_lsubr_2n. - - * scm.h eval.c (tc7_lsubr_2n): type added. Other subr types - rearranged. - -Sat Jul 11 23:47:18 1992 Aubrey Jaffer (jaffer at Ivan) - - * scm.h sys.c repl.c eval.c code.doc (newsmob smobs smobfuns): now - support dynamically added smob types. Promises moved to eval.c. - Promises and arbiters are now newsmobs. - - * makefile.unix repl.c scl.c (floprint): moved from repl.c to - scl.c. The only files which care about -DFLOATS are now scl.c, - eval.c, scm.c, and unif.c. - - * sys.c scm.h (init_storage): now uses variable num_protects - instead of #define NUM_PROTECTS. - -Tue Jul 7 00:00:57 1992 Aubrey Jaffer (jaffer at Ivan) - - From: Ulf_Moeller@hh2.maus.de (Ulf Moeller) - * Init.scm config.h makefile.prj: support for the ATARI-ST with - Turbo C added. - -Tue Jun 30 23:45:50 1992 Aubrey Jaffer (jaffer at Ivan) - - * unif.c (make-uniform-vector uniform-vector-set! - uniform-vector-ref): added. - -Tue Jun 23 11:49:13 1992 Aubrey Jaffer (jaffer at Ivan) - - * scm.h sys.c code.doc: rearranged tc7 codes and added bvect, - ivect, uvect, fvect, dvect, cvect, and cclo. - - * scm.h sys.c eval.c repl.c code.doc: Changed symbols to be - tc7_symbol. - -Sat Jun 6 22:27:40 1992 Aubrey Jaffer (jaffer at Ivan) - - From: campbell@redsox.bsw.com (Larry Campbell) - * scl.c (divide): divide by 0 and Exact-only divides of non - multiples now cause exception in RECKLESS mode. - -Wed May 27 16:02:58 1992 Aubrey Jaffer (jaffer at Ivan) - - * config.h scl.c (NUMBUFLEN): split into INTBUFLEN and FLOBUFLEN - and made proportional to size of numeric types. - - From: fred@sce.carleton.ca (Fred J Kaudel) - * makefile.ast scm.c Init.scm: minor chages for ATARI ST support. - - * test.scm (test-inexact): created. - -Thu May 21 11:43:41 1992 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 5 - - From: hugh@ear.mit.edu (Hugh Secker-Walker) - * config.h: better wording for heap allocation strategy - explanation. - -Wed May 20 00:31:18 1992 Aubrey Jaffer (jaffer at Ivan) - - From S.R.Adams@ecs.southampton.ac.uk - * subr.c (stci_leqp st_leqp): reversed order of ^ clauses to avoid - Borland 3.0 bug. - - * sys.c (gc_sweep): missing i-=2; added when splicing out segment. - - * MANUAL time.c (get-universal-time decode-universal-time): half - hearted attempt to add these. Needs bignums. - -Wed May 13 14:01:07 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (gc_mark): improved tail recursivness for CONSes. - - * repl.c (growth_mon): now prints out the hplims table if - verbose>3. - - * sys.c (init_heap_seg): Serious bug in growing hplims fixed. - num_heap_segs eliminated; hplims are realloced whenever grown. - -Tue May 12 15:36:17 1992 Aubrey Jaffer (jaffer at train) - - * config.h sys.c (alloc_some_heap expmem): expmem captures - whether the INIT_HEAP_SIZE allocation was successful. If so, - alloc_some_heap uses exponential heap allocation instead of - HEAP_SEG_SIZE. - -Mon May 11 15:29:04 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (gc_sweep init_heap_seg heap_org): Empty heap segments - are now freed. - - * sc2.c (STR_EXTENSIONS): renamed REV2_PROCEDURES and R2RS and - R3RS functions put into sc2.c. - -Sun May 10 01:34:11 1992 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (ignore_interrupts unignore_interrupts): added for - system, edt$edit, and popen to use. - - * repl.c (lwrite display newline write_char): Close pipe if EPIPE. - - * repl.c (file_set_position): now errs on ESPIPE. - - * scm.c (SIGPIPE): now ignored (errs come back as EPIPE). - -Sat May 9 17:52:36 1992 Aubrey Jaffer (jaffer at Ivan) - - From: Stephen Adams <S.R.Adams@ecs.southampton.ac.uk> - * config.h (PROT386): PROT386 added. PTR_LT and CELL_UP modified. - -Fri May 8 17:57:22 1992 Aubrey Jaffer (jaffer at Ivan) - - From: hugh@ear.mit.edu (Hugh Secker-Walker) - * Init.scm (last-pair append!): last-pair is faster version. - Append! corrected for null first arg. (getenv "HOME") now gets - a "/" added if not present. - - * config.scm (MIN_GC_YIELD): now proportional to HEAP_SEG_SIZE. - - * README: setting environment variables corrected. - - * subr.c (length): error message now has arg if not a list. - - * sys.c (open-pipe): now turns off interrupts before forking. - - * scl.c (lsystem): now turns off interrupts before forking. - - * scm.c (ignore_signals): created. - -Sat May 2 01:02:16 1992 Aubrey Jaffer (jaffer at Ivan) - - * Init.c (WITH-INPUT-FROM-FILE WITH-OUTPUT-TO-FILE): defined in - terms of current-input-port and current-output-port. Bug in - open-input-pipe and open-output-pipe fixed. - - * sys.c repl.c (current-input-port current-output-port): moved - from sys.c to repl.c. set-current-input-port and - set-current-output-port added to repl.c. - -Mon Apr 13 22:51:32 1992 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h: (PATCHLEVEL): released scm4a1. - - * makefile.* VMSBUILD.COM VMSGCC.COM: compile time.h. - - * scm.c (alrm_signal int_signal): now save and restore errno so - SYSCALL will work correctly across interrupts. - -Sun Apr 12 01:44:10 1992 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h: (PATCHLEVEL): released scm4a0. - - * repl.c (lread): tok_buf now local to each invocation of read. - This makes READ interruptable and reentrant. - - * sys.c MANUAL (STRING-SET-LENGTH! STRING-VECTOR-LENGTH!): created. - - * sys.c repl.c (grow_tok_buf tok_buf tok_buf_len): moved to repl.c - - * repl.c (lfwrite): now emulated for VMS. - - * repl.c scl.c (num_buf): now local to all routines that use it. - - * time.h: created by moving time functions from repl.c. Read and - write functions were moved from sys.c to repl.c. - - * sys.c repl.c (DEFER_INTS ALLOW_INTS CHECK_INTS): totally - rewritten. SIGALRM and SIGINT now execute at interrupt level. - Interrupts deferred only for protected code sections, not for - reads and writes. - - * sys.c repl.c (SYSCALL): created to reexecute system calls - interrupted (EINTR) by SIGALRM and SIGINT. - - * sys.c scl.c (flo0): 0.0 is now always flo0. - - * repl.c sys.c (TRANSCRIPT-ON TRANSCRIPT-OFF): added. This - required shadowing putc, fputs, fwrite, and getc with lputc, - lputs, lfwrite, and lgetc. - -Sun Apr 5 00:27:33 1992 Aubrey Jaffer (jaffer at Ivan) - - From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden) - * scl.c (eqp lessp greaterp lesseqp greatereqp): - Comparisons with inexact numbers was not being performed - correctly. For example, (< 1.0 2.0 1.5) would yield #t. What was - missing was a line x=y; in the inexact comparison sections of - lessp(), greaterp(), lesseqp() and greatereqp(). In addition, I - modified these routines and eqp() to allow for mixed arithmetic - types. - -Sat Apr 4 00:17:29 1992 Aubrey Jaffer (jaffer at Ivan) - - * scm.h code.doc: tc7_bignum => tc7_spare. Added tc16_bigpos and - tc16_bigneg. SMOBS reordered. tc16_record added. - - * scm.h repl.c sys.c (make-arbiter try-arbiter release-arbiter): - added. tc16_arbiter added. - -Fri Apr 3 01:25:35 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c config.h (TEMPTEMPLATE): created in config.h. - - * scm.h: removed long aliases for C versions of Scheme functions. - - * sys.c eval.c scm.h: (delay force makprom): added. Also added - tc16_promise data type. - - * Init.scm (trace untrace): added autoloads and read macros. - - From: T. Kurt Bond, tkb@mtnet2.wvnet.edu - * sys.c (template): correct template for VMS. - -Tue Mar 31 01:50:12 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c config.h Init.scm (open-file open-pipe): created and - expressed other open functions in terms of. Bracketed all i/o - system calls with DEFER and ALLOW _SIGINTS. - -Sat Mar 28 00:24:01 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c MANUAL (#.): read macro syntax added. Balanced comments - also documented. - -Fri Mar 27 22:53:26 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (iprin1): changed printed representation for unreadable - objects from #[...] to #<...>. - - From: brh@aquila.ahse.cdc.com (brian r hanson x6009): - * scm.h config.h (NCELLP PTR_LT): fixes for 64 bit pointers on - nosve. - -Fri Mar 20 01:36:08 1992 Aubrey Jaffer (jaffer at Ivan) - - * Released scm3c13 - - * code.doc: corrected some minor inconsistencies and added a - section "To add a package of new procedures to scm". - -Sun Mar 15 19:44:45 1992 Aubrey Jaffer (jaffer at Ivan) - - * Init.scm: now loads <program-name>_INIT_PATH when <program-name> - is not "SCM". - - * config.h (PTR_LT): (x < y) => ((x) < (y)) - -Wed Mar 4 01:53:15 1992 Aubrey Jaffer (jaffer at Ivan) - - * Released scm3c12. - - * scm.h code.doc eval.c sys.c (IXSYM): Eliminated Immediate IXSYM - type. - -Tue Mar 3 00:58:18 1992 Aubrey Jaffer (jaffer at Ivan) - - * eval.c config.c (ceval DEFINED? SYNTAX_EXTENSIONS): added - DEFINED? to ceval conditional on SYNTAX_EXTENSIONS. - - From: Andrew Wilcox <andrew@astro.psu.edu> - * makefile.unix scm.c (main init_scm display_banner init_signals - restore_signals run_scm): RTL support. - -Mon Mar 2 19:05:29 1992 Aubrey Jaffer (jaffer at Ivan) - - * subr.c (make-string): now checks for ARG1 >= 0. - -Fri Feb 28 00:13:00 1992 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 12 - - * Init.scm: loads JCAL if scm is invoked with name JCAL, JACAL, - jcal or jacal. - - * Init.scm (ABS): set to MAGNITUDE if FLOATS are supported. - - * gc_mark gc: no longer assume sizeof(short) == 2. - - * config.h (CELL_UP CELL_DN): no longer assume sizeof(CELL) == 8. - - From: Brian Hanson, Control Data Corporation. brh@ahse.cdc.com - * scl.c config.h repl.c: partial port to Control Data NOS/VE. - - From: fred@sce.carleton.ca (Fred J Kaudel) - * repl.c Init.scm makefile.ast: Port to Atari-ST - - * sys.c scm.h eval.c (throw): renamed to lthrow to avoid conflict - with Gnu CC. - -Mon Feb 10 14:31:24 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (delete-file rename-file): added. - - * sys.c (chdir): now returns #f instead of error. - - * Init.scm: Calls to PROVIDED? inlined so no longer dependent on - SLIB being loaded. (set! ABS MAGNITUDE) if inexacts supported. - Support for slib1b3 added. - - * sys.c (alloc_some_heap): fixed bugs. One fix from - bowles@is.s.u-tokyo.ac.jp. - - * eval.c (ceval): fixed bug with internal (define foo bar) where - bar is a global. Put badfun2: back in for better error reporting. - - * patchlvl.h (PATCHLEVEL): 11 - -Mon Jan 20 16:19:04 1992 Aubrey Jaffer (jaffer at Ivan) - - * config.c (INITS): comments added. - - From: T. Kurt Bond, tkb@mtnet2.wvnet.edu - * VMSGCC.COM VMSMAKE.COM: now take arguments. - - From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de> - * makefile.aztec repl.c: Aztec C (makefile) port. - -Fri Jan 17 16:36:07 1992 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (gc init_storage stack_size): stack_size now of type - sizet. init_storage no longer uses it. gc() now uses it instead - of pointer to local. This fixes bug with gcc -O. - - * sys.c (cons cons2 cons2r): &w;&x;&y; removed because of above - fix. - -Thu Jan 16 22:33:00 1992 Aubrey Jaffer (jaffer at Ivan) - - * scl.c (real-part): added. - -Wed Jan 15 13:06:39 1992 Aubrey Jaffer (jaffer at Ivan) - - From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de> - * scl.c repl.c scm.c config.c: Port for AMIGA - - * scm.h (REALP): fixed for SINGLES not defined. - -Sat Jan 11 20:20:40 1992 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 8 released. - - * README: added hints for EDITING SCHEME CODE. - - * repl.c (SIGRETTYPE): now int for __TURBOC__. - - * makefile.tur makefile.djg: created. - - * config.h: DJGPP (__GO32__) support added. - - * scm.h (memv): definition added. - -Sun Jan 5 00:33:44 1992 Aubrey Jaffer (jaffer at Ivan) - - * repl.c makefile.* (main): INITS added. - - * scl.c: fixed ASSERT statements with mismatched ARGn and - arguments. - -Thu Dec 19 19:16:50 1991 Aubrey Jaffer (jaffer at train) - - * sys.c (cons cons2 cons2r): added fix for gcc -O bug. - - * repl.c (LACK_FTIME LACK_TIMES): more messing with these. - - * sys.c config.o (HAVE_PIPE): created. - - * config.h (FLT_RADIX): now #ifdef FLT_RADIX rather than __STDC__. - Needed for DJGCC. - - * sys.c (DBLMANT_DIG DBL_FLOAT_DIG): now tested for directly - rather than STDC_INCLUDES. - - * makefile.unix (subr.o): explicit compilation line added. - - * scl.c (truncate -> ltrunc): Name conflict with DJGCC libraries. - -Sun Dec 8 23:31:04 1991 Aubrey Jaffer (jaffer at Ivan) - - * eval.c (apply): added check for number of args to closures. - -Sat Dec 7 01:30:46 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 7 - - * sys.c (chdir): THINK_C doesn't support; - - * repl.c: SVR2 needs <time.h> instead of <sys/time.h> - - * repl.c: SVR2 needs LACK_FTIME - - * repl.c: #include <sys/timeb.h> now automatic ifndef LACK_FTIME. - -Mon Dec 2 15:42:11 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 5 - - * sys.c (intern sysintern): made strings and hash unsigned. Fixed - bug with characters > 128 in symbols. - - * scl.c (eqv? memv assv): created if FLOATS is #defined. From - boopsy!mike@maccs.dcss.mcmaster.ca (Michael A. Borza). - -Mon Dec 2 11:37:11 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 4 - - * sys.c (gc_sweep): usaage of pclose() now conditional on unix. - - * MANUAL (chdir): documented. - - from T. Kurt Bond, Adminisoft, Inc. <tkb@MTNET2.WVNET.EDU>: - - * repl.c sys.c (errno): VMS GNU C uses a special hack in <errno.h> - to get the link-time attributes for the errno variable to match - those the VMS C run-time library expects (it makes errno a - preprocessor define so that the variable that the compiler sees - has a special form that the assember then interprets), so if it is - VMS and __GNUC__ is defined <errno.h> needs included. - - * setjump.h (SETJUMP LONGJUMP): SETJUMP and LONGJUMP changed to - setjump and longjump. The VMS linker is case-indifferent. VMS GNU - C mangles variable names that have upper case letters in them to - preserve their uniqueness. - - * sys.c (iprint iprin1): Now inline putc loops instead of calls to - fwrite for VMS. The VMS `fwrite' has been enhanced to work with - VMS's Record Management Sevice, RMS. Part of this enhancement is - to treat each call to `fwrite' as producing a separate record. - This works fine if you are writing to a stream_LF file or an - actual terminal screen, but if you are writing to a file that has - implied carriage control (such as a batch log file, or a mailbox - used for subprocess communication), which is a more common file - organization for RMS, each call to `fwrite' has a newline appended - to it. This causes much of the output to be incorrectly split - across lines. - - * vmsgcc.com: created. - -Sun Dec 1 00:33:42 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 3 released. - - * Init.scm (rev2-procedures): all now supported. - - * Init.scm sys.c MANUAL (flush): flush changed to force-output to - be compatible with Common Lisp. - - * sys.c (chdir): added. - -Wed Nov 27 09:37:20 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 2 - - * repl.c (set-errno! perror): added. - - * sys.c (gc): FLUSH_REGISTER_WINDOWS call added. - - * sys.c (open-input-pipe open-output-pipe close-pipe): added. - -Mon Nov 25 13:02:13 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 1 - - * sys.c (flush): added. - - * repl.c (mytime): macro was missing (). CLKTCK now defaults to 60. - - * README Init.scm subr.c scm.c repl.c scl.c: From Yasuaki Honda, - honda@csl.SONY.co.jp, support for Macintosh running Think C. - -Sun Nov 24 15:30:51 1991 Aubrey Jaffer (jaffer at Ivan) - - * scl.c (str2flo): fixed parsing of -1-i. - - * repl.c (repl_driver): from jjc@jclark.com, now checks that - s_response is non-NULL before INTERNing. - - * subr.c (equal): Now correct for inexacts. Need to do eqv. - - * scm.h (REALPART): fixed pixel C compiler bug with doubles inside - `?' conditionals. - - * scl.c (zerop): now checks imaginary half of complex number. - -Tue Nov 19 00:10:59 1991 Aubrey Jaffer (jaffer at Ivan) - - * version scm3c0 - - * documentation: changed revised^3.99 to revised^4. - - * example.scm: created from Scheme^4 spec. - - * makefile.msc: -Ox changed to -Oxp to fix over-enthusiastic float - optimizations. - - * Init.scm (ed): defined. - - * repl.c (def_err_response): UNDEFINED objects don't print out. - -Sun Nov 17 23:11:03 1991 Aubrey Jaffer (jaffer at Ivan) - - * scl.c (vms-debug): now returns UNSPECIFIED. - - * repl.c MANUAL (restart_repl): RESTART-REPL changed to ABORT. - - * repl.c (err_ctrl_c):now clears sig_pending. - -Wed Nov 13 23:51:36 1991 Aubrey Jaffer (jaffer at Ivan) - - * config.h: removed #ifdef sparc #define STDC_HEADERS - - * makefile.bor: added extra '\' to filepath. - - * repl.c (everr): fixed bug with ARGx. - - * repl.c (errmsgs def_err_response): cleaned up error messages. - -Sun Nov 10 23:10:24 1991 Aubrey Jaffer (jaffer at Ivan) - - * released scm3b7 - -Mon Nov 4 18:36:49 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 6 - - * sys.c (idbl2str): tests for Not-a-Number and Infinity added. - - * repl.c scm.h: response system rewritten and integrated with - error system. - - * scl.c (/): now returns inexacts if integer arguments do not - divide evenly. - -Mon Oct 28 23:44:16 1991 Aubrey Jaffer (jaffer at Ivan) - - * makefile.unix: can now make float (scm) and integer-only (escm) - versions in same directory. - - * repl.c (*sigint-response* *arithmetic-response* restart-repl): - responses for signals added. - - * scl.c (lmin lmax sum difference product divide expt exp log): - now take mixed types. expt available in non-FLOATS compilation. - - * repl.c (get-decoded-time): added. Includes and time functions - reorganized. - - * sys.c (object-hash object-unhash): added. - -Tue Oct 15 00:45:35 1991 Aubrey Jaffer (jaffer at Ivan) - - * repl.c Init.scm (*features*): moved constant features into - Init.scm. Moved tests for numeric features to slib/require.scm. - - * release scm3b1. - - * config.h (ANSI_INCLUDES): redid include files. - - * subr.c scl.c: moved all FLOAT conditionals from subr.c to scl.c. - -Wed Oct 9 00:28:54 1991 Aubrey Jaffer (jaffer at Ivan) - - * release scm3a13. - - * patchlvl.h (PATCHLEVEL): 13 - - * Init.scm: "vicinity.scm" changed to "require.scm" - -Mon Oct 7 00:34:07 1991 Aubrey Jaffer (jaffer at Ivan) - - * test.scm: test of redefining built-in symbol and extra ')' - removed. - - * scm.doc makefile.unix: scm.doc created from scm.1 in - makefile.unix. - - * VMSBUILD.COM setjump.asm setjump.h (setjmp longjmp jmp_buf): put - in from comp.sources.reviewed in order to let VMS have full - continuations. VMSBUILD.COM is a compile script. - -Fri Oct 4 00:05:54 1991 Aubrey Jaffer (jaffer at Ivan) - - * scl.c(sleep): removed; not supported by MSC (although could be - written). - - * scm.h config.h (size_t): moved to config.h. - - * sys.c (f_getc): -> lgetc for vax, getc otherwise. - - * patchlvl.h (PATCHLEVEL): 12 - -Mon Sep 30 01:14:48 1991 Aubrey Jaffer (jaffer at Ivan) - - * scl.c(sleep): created. - - * repl.c(internal-time-units-per-second get=internal-run-time): - created - - * repl.c: created from scm.c (shuffled around lots of functions). - -Sat Sep 28 00:22:30 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c config.h (char-code-limit most-positive-fixnum - most-negative-fixnum): created. - -Tue Sep 24 01:21:43 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (software-type); created. - - * scm.c config.h (terms, list-file, library-vicinity, - program-vicinity, user-vicinity, make-vicinity, sub-vicinity): - moved to Init.scm and library. - - * scm.c config.h Makefile (PROGPATH): changed to IMPLPATH. - - * Init.scm: created - -Fri Sep 20 13:22:08 1991 Aubrey Jaffer (jaffer at Ivan) - - * patchlvl.h (PATCHLEVEL): 5 - - * all: changed declarations to size_t where appropriate. scm.h - test preprocessor flag _SIZE_T to determine if already declared. - size_t should greatly enhance portability to Macintosh and other - machines. - -Tue Sep 17 01:15:31 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (tmpnam): support for mktemp added. - -Mon Sep 16 14:06:26 1991 Aubrey Jaffer (jaffer at train) - - * scm.c (implementation-vicinity): added. (program-vicinity) now - returns undefined if called not within a load. - - * sys.c (call-with-io-file): removed. - - * scm.c (tmpnam): added. - - * scm.c config.h (tmporary-vicinity): removed. - -Sun Sep 15 22:21:30 1991 Aubrey Jaffer (jaffer at Ivan) - - * subr.c scm.h (remainder): renamed to lremainder to avoid - conflict with math.h on SunOS4.1 (from bevan@cs.man.ac.uk). - -Sat Sep 7 22:27:49 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (program-arguments load): program-arguments created. - - * scm.c (getenv): added getenv and used for program-vicinity and - library-vicinity. - - * scm.c (program-vicinity): fixed if load_name is NULL. - - * scl.c config.h (substring-move-left! substring-move-right!): - added under STR_EXTENSIONS flag. - -Wed Aug 28 22:59:20 1991 Aubrey Jaffer (jaffer at Ivan) - - * Sending scm3a to comp.sources.reviewed - - * scm.c (main): prints out feature list at startup. - - * subr.c (eqp lessp greaterp lesseqp greatereqp): now work for - floats. - - * scl.c (sum difference divide product): moved to scl.c and - now work for floats. - - * all: all masks with low bits explicity cast to (int). - -Sat Aug 17 00:39:06 1991 Aubrey Jaffer (jaffer at Ivan) - - * sys.c subr.c scl.c (iint2str istr2int istring2number istr2flo - iflo2str idbl2str): number I/O and conversion to strings rewritten. - - * sys.c (gc_mark): continuations now marked SHORT_ALIGNed. (from - Craig Lawson). - - * added QuickC support from Craig Lawson. - -Tue Jul 30 01:08:52 1991 Aubrey Jaffer (jaffer at Ivan) - - * config.h: #ifdef pyr added. - - * scm.c MANUAL: vicinity functions added. - -Tue Jul 16 00:51:23 1991 Aubrey Jaffer (jaffer at Ivan) - - * scl.c sys.c: float functions added. - - * Documentation reorganized according to comp.sources.reviewed - guidelines. - - * sys.c config.h (open_input_file open_output_file open_rw_file): - file mode string moved to defines in config.h - -Thu Jul 11 23:30:03 1991 Aubrey Jaffer (jaffer at Ivan) - - * sys.c config.h (EBCDIC ASCII) moved to config.h - - * subr.c config.h (BADIVSGNS) moved to config.h - - * scm.h config.h (SRS) moved to config.h - -Sun Jul 7 23:49:26 1991 Aubrey Jaffer (jaffer at Ivan) - - * all: started adding comp.sources.reviewed corrections and - suggestions. - - * scm.c patchlvl.h (main): PATCHLEVEL now printed in banner. - - * subr.c sys.c: read_integer removed. istring2number created. - lread and string2number now both use istring2number. - -Fri Jun 7 13:43:40 1991 Aubrey Jaffer (jaffer at Ivan) - - * VERSION scm2e sent to comp.sources.reviewed - - * public.lic: renamed COPYING. - - * scm.c (gc_status): gc_status renamed prolixity. Now returns old - value of verbose. Can take 0 arguments. - - * sys.c (lreadr): added #| common lisp style |# balanced comments. - - * scm.h scm.c sys.c (I/O functions): combined **PORTP and OPENP to - become OP**PORTP. - - * scm.h sys.c (gc_sweep): moved OPENP to bit in upper half word of - port cells. - -Sat May 25 00:04:45 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (stack_start_ptr, repl_driver, main, err functions): - exits removed from all err functions. all escapes through - repl_driver. - - * scm.c README (verbose): Now has graded verbosity. - - * scm.c README (quit): Now takes optional argument which is return - value. - -Wed May 22 01:40:17 1991 Aubrey Jaffer (jaffer at Ivan) - - * code.doc scm.h eval.c (ceval): Rearanged immediate type codes to - create IXSYMs (immediate extension syms) to allow more than 15 - special forms. ILOCs now work with up to 32767 in one environment - frame. Dispatch is slightly faster for ILOCs in function position. - ICHRs can be up to 24 bits. - -Fri May 10 00:16:32 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.h sys.c (gc_mark, gc_sweep): GCMARK moved to bit 8 of CAR - for some datatypes. - -Wed May 1 14:11:05 1991 Aubrey Jaffer (jaffer at Ivan) - - * patch1 MESSAGE SENT. - - * sys.c (lreadr) from jclark@bugs.specialix.co.uk.jjc: removed - order evaluation bug when growing tok_buf. - -Fri Apr 26 10:39:41 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm2d RELEASED - - * sys.c (closure) no longer calls ilength (ECONS problem). Added - ASSERT before call to closure in eval. - -Thu Apr 25 09:53:40 1991 Aubrey Jaffer (jaffer at Ivan) - - * scm.c (error): created. - -Wed Apr 24 16:58:06 1991 Aubrey Jaffer (jaffer at Ivan) - - * utils.scm: created. - - * makefile (name8s): code from dmason works in makefile. - - * eval.c (evalcar): fixed errobj on (else 3 4) error. - Inlined function application in (cond ((foo => fun))). - - * sys.c (lprin1): change looped putcs to fwrite. - -Wed Apr 24 01:54:09 1991 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (lreadr): fixed assert for "eof in string". - - * subr.c (lgcd): changed to work with borland C. - - * eval.c (eval): added checks to LAMBDA and LET. - - * eval.c (apply): now checks for null arg1 in lsubr. - -Fri Apr 12 00:09:03 1991 Aubrey Jaffer (jaffer at kleph) - - * config.h scm.h (SCMPTR): created to correct address arithmetic - on stack bounds under Borland C++. Borland C++ now runs scm2c. - -Wed Apr 10 21:38:09 1991 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (open_io_file, cw_io_file, file_position, file_set_pos, - read_to_str) created (IO_EXTENSIONS) - - * config.h (IO_EXTENSIONS): defined - - * sys.c scm.c: lprin1f changed to iprin1 - -Wed Apr 10 12:58:59 1991 Aubrey Jaffer (jaffer at Ivan) - - * sys.c (intern): line 850: for(i = alen;0 <= --i;)changed to - for(i = alen;0 < --i;). - This fixed b_pos and v_pos mapping to the same symbol. - -Wed Apr 4 00:00:00 1991 Aubrey Jaffer (jaffer at kleph.ai.mit.edu) - - * released scm2b - -Wed Apr 3 22:51:39 1991 Aubrey Jaffer (jaffer at Ivan) - - * all files: eliminated types tc7_subr_2n and tc7_subr_2xn. - Replaced with tc7_subr_2o and tc7_subr_1o so that all subr calls - can be checked for number of arguments. - -Tue Apr 2 23:11:15 1991 Aubrey Jaffer (jaffer at Ivan) - - * code.doc: cleaned up. - -Mon Apr 1 14:27:22 1991 Aubrey Jaffer (jaffer at Ivan) - - * eval.c (ceval): fixed nasty tail recursion bug at carloop:. - - * scm.c (everr): still fixing error reporting. - - * eval.c subr.c: added flag PURE_FUNCTIONAL which removes side - effect special forms and functions. - - * subr.c (substring): now allows first index to be equal to length - of string - - * sys.c (lprin1f): dispatches on TYP16 of smobs. - - * scm.h: fixed typo in unused function defs. - -Mon Mar 28 00:00:00 1991 Aubrey Jaffer (jaffer at zohar.ai.mit.edu) - - * scm2a released: too many changes to record. See code.doc. - -Mon Feb 18 21:48:24 1991 Aubrey Jaffer (jaffer at foxkid) - - * scm.h: types reformatted (TYP6 -> TYP7). - - * eval.c (ceval): Now dispatch directly on ISYMs in ceval. - -Fri Feb 15 23:39:48 1991 Aubrey Jaffer (jaffer at foxkid) - - * sys.c: #include <malloc.h> not done for VMS - -Wed Feb 13 17:49:33 1991 Aubrey Jaffer (jaffer at foxkid) - - * scm.c scl.c: added unsigned declarations to some char * - definitions in order to fix characters having negative codes. - - * scm.h (MAKISYM, MAKFLAG, ICHR, MAKICHR, MAKINUM): Now cast to - long so that their calls don't have to. Changing MAKICHR fixed - problem in scl.c (string2list) on IBMPC. - - * subr.c (quotient): support for `/' reintroduced; required by - r3.99rs but not IEEE. - - * subr.c (char functions): added isascii tests for - char-alphabetic, char-numeric?, char-whitespace?, - char-upper-case?, and char-lower-case?. Added test against - char_code_limit to int2char. - - * subr.c (s_char_alphap): is subr_1 not lsubr. - - * test.scm: added tests for char-alphabetic, char-numeric?, - char-whitespace?, char-upper-case?, and char-lower-case?. - - * sys.c: most `return;'s eliminated to reduce warning messages. - Substituted breaks and reordered switch and if clauses. - -Sun Feb 3 23:12:34 1991 Aubrey Jaffer (jaffer at foxkid) - - * scm1-2: released. - - * sys.c (read-char peek-char) added code for EOF. - - * test.scm (leaf-eq?) added and file "cont.scm" removed. I/O - tests added. - - * sys.c (I/O functions) now check for input and output ports - rather than just ports. - - * sys.c (lprin1f): occurences of stdout changed to f. Newlines - after printing port removed. - -Thu Jan 31 22:52:39 1991 Aubrey Jaffer (jaffer at foxkid) - - * subr.c (quotient): support for `/' removed; not required. - - * scm.c (wta): message for OUTOFRANGE fixed. - -Mon Jan 28 12:45:55 1991 Aubrey Jaffer (jaffer at foxkid) - - * eval.c (apply): added checks for number of arguments. - - * scm.h (CHECK_SIGINT): checks for blocked SIGINT. - - * sys.c (lprin1): added blocking and testing for SIGINT so that - output won't hang on VMS. - - * scm.c (repl): added fflush call. - - * scm.c (err_head, wta): added fflush calls to error routines so - that error message come out in proper order. - diff --git a/libguile/DYNAMIC-LINKING b/libguile/DYNAMIC-LINKING deleted file mode 100644 index cb7134318..000000000 --- a/libguile/DYNAMIC-LINKING +++ /dev/null @@ -1,95 +0,0 @@ -Random notes about dynamic linking for Guile. I will update this file -as I go along. Comments are very welcome. I can be reached at -mvo@zagadka.ping.de (Marius Vollmer). - -The dynamic linking support is mostly untested. I can't test it -because I don't have all the different platforms, of course. Please -try it out. - -To enable support for dynamic linking in libguile, give the - - --enable-dynamic-linking - -option to configure. It is disabled by default because it will -probably cause lots of problems in its present state. Currently there -is support for -ldld, -ldl, HP-UX (and VMS, but not really). - -Files affected: - - dynl* new - configure.in add --enable-dynamic-linking option and checking for - system dependencies - Makefile.am include dynl* in build and dist. - init.c initialize dynamic linking support - -Here is my plan with indications of progress. - -- port "dynl.c" and maybe some parts of "Link.scm" from SCM to - Guile. This should not be difficult, maybe I can even squeeze the - VMS code into the "dynl:link", "dyn:call" interface. - -* Mostly done, except VMS, and almost completely untested. The -dl - support should work, but the rest has not even been compiled. - - The code is in the "dynl*" files. "dynl.c" is the system independent - portion and includes the appropriate system dependent file, either - "dynl-dld.c", "dynl-dl.c" or "dynl-shl.c". - - I have renamed the SCM names of the functions, because they didnn't - fit very well into Guile, the semantics are the same: - - SCM name Guile name - - dynl:link dynamic-link - dynl:call dynamic-call - dynl:main-call dynamic-args-call - dynl:unlink dynamic-unlink - - I plan to generalise dynamic-call and dynamic-args-call to work with - arbitrary arguments, so these names are likely to change. - - PROBLEMS: - - When including dynlink support in libguile you need to link your - applications with additional libraries (-ldl or -ldld). How do you - communicate this to "guile" and "gh_test" for example? Some PLUGIN - magic? - - You may need to link your application in a special way to make - dynamic linking work. For example, on Linux and a statically linked - libguile.a, you need -rdynamic to make the libguile symbols - available for dynamic linking. The solution is probably to build - libguile as a shared library on the systems that support it. Does - libtool help here? Where can I find it? - - -- see how to couple dynamic linking with the module system. Dynamic - objects should have a way to specify the module they want to add - their bindings to. Extend this to statically linked parts of - guile. (i.e. posix could be put into a module and initialized on - demand) - -* Maybe it will suffice to have scm_make_gsubr, etc to honor the - current scm_top_level_lookup_closure and do all the module switching - from Scheme. - - -- use gtcltk as a test case for the above, so that TCL/Tk capabilities - can be added to guile at runtime. - -- see how G-Wrap and libffi can work together and extend dyn:call to - functions taking arbitrary arguments. Something along the lines - - (define XOpenDisplay (make-foreign-function X11-lib 'XOpenDisplay - .. whatever args ..)) - - -I have no ideas how to support the development of packages for Guile -that can be dynamically linked into a running application. Maybe -automake can be used to automate most of the issues. - -One nice thing is, however, that developers and users of Guile -packages have already installed Guile. So we might able to use Scheme -to describe and handle the build process. I would like that much more -than the arcane shell based implementations of autoconf, automake, -etc. diff --git a/libguile/Makefile.am b/libguile/Makefile.am deleted file mode 100644 index b944b49be..000000000 --- a/libguile/Makefile.am +++ /dev/null @@ -1,60 +0,0 @@ -## Process this file with Automake to create Makefile.in - -AUTOMAKE_OPTIONS = foreign - -## Check for headers in $(srcdir)/.., so that #include -## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're -## building. -INCLUDES = -I.. -I$(srcdir)/.. - -lib_LIBRARIES = libguile.a -libguile_a_SOURCES = alist.c append.c appinit.c arbiters.c async.c \ -backtrace.c boolean.c chars.c continuations.c debug.c dynl.c dynwind.c eq.c \ -error.c eval.c extchrs.c fdsocket.c feature.c filesys.c fports.c gc.c \ -gdbint.c genio.c gsubr.c hash.c hashtab.c inet_aton.c init.c ioext.c \ -kw.c list.c load.c mallocs.c markers.c mbstrings.c numbers.c objprop.c \ -options.c pairs.c ports.c posix.c print.c procprop.c procs.c ramap.c \ -read.c root.c scmsigs.c sequences.c simpos.c smob.c socket.c srcprop.c \ -stackchk.c stacks.c stime.c strerror.c strings.c strop.c strorder.c \ -strports.c struct.c symbols.c tag.c throw.c unif.c variable.c \ -vectors.c version.c vports.c weaks.c _scm.h - -include_HEADERS = libguile.h - -# These are headers visible as <libguile/mumble.h>. -modincludedir = $(includedir)/@module@ -modinclude_HEADERS = __scm.h alist.h append.h arbiters.h async.h \ -backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h eq.h \ -error.h eval.h extchrs.h fdsocket.h feature.h filesys.h fports.h gc.h \ -gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h ioext.h \ -kw.h list.h load.h mallocs.h markers.h mbstrings.h numbers.h objprop.h \ -options.h pairs.h ports.h posix.h print.h procprop.h procs.h ramap.h read.h \ -root.h scmhob.h scmsigs.h sequences.h simpos.h smob.h socket.h srcprop.h \ -stackchk.h stacks.h stime.h strings.h strop.h strorder.h strports.h struct.h \ -symbols.h tag.h tags.h throw.h unif.h variable.h vectors.h version.h \ -vports.h weaks.h snarf.h - -## This file is generated at configure time. That is why it is DATA -## and not a header -- headers are included in the distribution. -modinclude_DATA = scmconfig.h - -bin_SCRIPTS = guile-snarf - -EXTRA_DIST = gscm.c gscm.h ChangeLog-scm dynl-dl.c dynl-dld.c dynl-shl.c \ -dynl-vms.c PLUGIN/REQ PLUGIN/guile.config PLUGIN/guile.libs - -## FIXME: shouldn't directly generate file; instead generate temp file -## and "mv". Consider using timestamp file as well, to avoid -## unnecessary rebuilds. -libpath.h: Makefile - echo '/* generated by Makefile */' > libpath.h - echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.h - echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(VERSION)"' >> libpath.h - echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.h - -SUFFIXES = .x -.c.x: - ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ - -## Add -MG to make the .x magic work with auto-dep code. -MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) diff --git a/libguile/Makefile.in b/libguile/Makefile.in deleted file mode 100644 index 6c779f9e3..000000000 --- a/libguile/Makefile.in +++ /dev/null @@ -1,478 +0,0 @@ -# Makefile.in generated automatically by automake 1.1l from Makefile.am - -# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. -# This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - - -SHELL = /bin/sh - -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -VPATH = @srcdir@ -prefix = @prefix@ -exec_prefix = @exec_prefix@ - -bindir = @bindir@ -sbindir = @sbindir@ -libexecdir = @libexecdir@ -datadir = @datadir@ -sysconfdir = @sysconfdir@ -sharedstatedir = @sharedstatedir@ -localstatedir = @localstatedir@ -libdir = @libdir@ -infodir = @infodir@ -mandir = @mandir@ -includedir = @includedir@ -oldincludedir = /usr/include - -pkgdatadir = $(datadir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ - -top_builddir = . - -INSTALL = @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -transform = @program_transform_name@ -VERSION = @VERSION@ -RANLIB = @RANLIB@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -module = @module@ -CC = @CC@ -PACKAGE = @PACKAGE@ -FD_SETTER = @FD_SETTER@ - -AUTOMAKE_OPTIONS = foreign - -INCLUDES = -I.. -I$(srcdir)/.. - -lib_LIBRARIES = libguile.a -libguile_a_SOURCES = alist.c append.c appinit.c arbiters.c async.c \ -backtrace.c boolean.c chars.c continuations.c debug.c dynl.c dynwind.c eq.c \ -error.c eval.c extchrs.c fdsocket.c feature.c filesys.c fports.c gc.c \ -gdbint.c genio.c gsubr.c hash.c hashtab.c inet_aton.c init.c ioext.c \ -kw.c list.c load.c mallocs.c markers.c mbstrings.c numbers.c objprop.c \ -options.c pairs.c ports.c posix.c print.c procprop.c procs.c ramap.c \ -read.c root.c scmsigs.c sequences.c simpos.c smob.c socket.c srcprop.c \ -stackchk.c stacks.c stime.c strerror.c strings.c strop.c strorder.c \ -strports.c struct.c symbols.c tag.c throw.c unif.c variable.c \ -vectors.c version.c vports.c weaks.c _scm.h - -include_HEADERS = libguile.h - -# These are headers visible as <libguile/mumble.h>. -modincludedir = $(includedir)/@module@ -modinclude_HEADERS = __scm.h alist.h append.h arbiters.h async.h \ -backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h eq.h \ -error.h eval.h extchrs.h fdsocket.h feature.h filesys.h fports.h gc.h \ -gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h ioext.h \ -kw.h list.h load.h mallocs.h markers.h mbstrings.h numbers.h objprop.h \ -options.h pairs.h ports.h posix.h print.h procprop.h procs.h ramap.h read.h \ -root.h scmhob.h scmsigs.h sequences.h simpos.h smob.h socket.h srcprop.h \ -stackchk.h stacks.h stime.h strings.h strop.h strorder.h strports.h struct.h \ -symbols.h tag.h tags.h throw.h unif.h variable.h vectors.h version.h \ -vports.h weaks.h snarf.h - -modinclude_DATA = scmconfig.h - -bin_SCRIPTS = guile-snarf - -EXTRA_DIST = gscm.c gscm.h ChangeLog-scm dynl-dl.c dynl-dld.c dynl-shl.c \ -dynl-vms.c PLUGIN/REQ PLUGIN/guile.config PLUGIN/guile.libs - -SUFFIXES = .x - -MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) -ACLOCAL = $(top_srcdir)/aclocal.m4 -CONFIG_HEADER_IN = scmconfig.h.in -mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs -CONFIG_HEADER = scmconfig.h -CONFIG_CLEAN_FILES = fd.h guile-snarf -LIBRARIES = $(lib_LIBRARIES) - - -DEFS = @DEFS@ -I. -I$(srcdir) -I. -CPPFLAGS = @CPPFLAGS@ -LDFLAGS = @LDFLAGS@ -LIBS = @LIBS@ -libguile_a_LIBADD = -libguile_a_OBJECTS = alist.o append.o appinit.o arbiters.o async.o \ -backtrace.o boolean.o chars.o continuations.o debug.o dynl.o dynwind.o \ -eq.o error.o eval.o extchrs.o fdsocket.o feature.o filesys.o fports.o \ -gc.o gdbint.o genio.o gsubr.o hash.o hashtab.o inet_aton.o init.o \ -ioext.o kw.o list.o load.o mallocs.o markers.o mbstrings.o numbers.o \ -objprop.o options.o pairs.o ports.o posix.o print.o procprop.o procs.o \ -ramap.o read.o root.o scmsigs.o sequences.o simpos.o smob.o socket.o \ -srcprop.o stackchk.o stacks.o stime.o strerror.o strings.o strop.o \ -strorder.o strports.o struct.o symbols.o tag.o throw.o unif.o \ -variable.o vectors.o version.o vports.o weaks.o -AR = ar -SCRIPTS = $(bin_SCRIPTS) - -CFLAGS = @CFLAGS@ -COMPILE = $(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) -LINK = $(CC) $(LDFLAGS) -o $@ -DATA = $(modinclude_DATA) - -HEADERS = $(modinclude_HEADERS) $(include_HEADERS) - -DIST_COMMON = COPYING ChangeLog Makefile.am Makefile.in acconfig.h \ -acinclude.m4 aclocal.m4 configure configure.in fd.h.in guile-snarf.in \ -scmconfig.h.in stamp-h.in - - -DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \ - $(TEXINFOS) $(MANS) $(EXTRA_DIST) - -TAR = tar -DEP_FILES = .deps/alist.P .deps/append.P .deps/appinit.P \ -.deps/arbiters.P .deps/async.P .deps/backtrace.P .deps/boolean.P \ -.deps/chars.P .deps/continuations.P .deps/debug.P .deps/dynl.P \ -.deps/dynwind.P .deps/eq.P .deps/error.P .deps/eval.P .deps/extchrs.P \ -.deps/fdsocket.P .deps/feature.P .deps/filesys.P .deps/fports.P \ -.deps/gc.P .deps/gdbint.P .deps/genio.P .deps/gsubr.P .deps/hash.P \ -.deps/hashtab.P .deps/inet_aton.P .deps/init.P .deps/ioext.P .deps/kw.P \ -.deps/list.P .deps/load.P .deps/mallocs.P .deps/markers.P \ -.deps/mbstrings.P .deps/numbers.P .deps/objprop.P .deps/options.P \ -.deps/pairs.P .deps/ports.P .deps/posix.P .deps/print.P \ -.deps/procprop.P .deps/procs.P .deps/ramap.P .deps/read.P .deps/root.P \ -.deps/scmsigs.P .deps/sequences.P .deps/simpos.P .deps/smob.P \ -.deps/socket.P .deps/srcprop.P .deps/stackchk.P .deps/stacks.P \ -.deps/stime.P .deps/strerror.P .deps/strings.P .deps/strop.P \ -.deps/strorder.P .deps/strports.P .deps/struct.P .deps/symbols.P \ -.deps/tag.P .deps/throw.P .deps/unif.P .deps/variable.P .deps/vectors.P \ -.deps/version.P .deps/vports.P .deps/weaks.P -SOURCES = $(libguile_a_SOURCES) -OBJECTS = $(libguile_a_OBJECTS) - -default: all - -.SUFFIXES: -.SUFFIXES: .c .o .x -$(srcdir)/Makefile.in: Makefile.am $(top_srcdir)/configure.in $(ACLOCAL) - cd $(top_srcdir) && automake --foreign Makefile - -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES) - cd $(top_builddir) \ - && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status - -$(srcdir)/aclocal.m4: configure.in acinclude.m4 - cd $(srcdir) && aclocal - -config.status: configure - $(SHELL) ./config.status --recheck -$(srcdir)/configure: configure.in $(ACLOCAL) $(CONFIGURE_DEPENDENCIES) - cd $(srcdir) && autoconf - -$(CONFIG_HEADER): stamp-h -stamp-h: $(CONFIG_HEADER_IN) $(top_builddir)/config.status - cd $(top_builddir) \ - && CONFIG_FILES= CONFIG_HEADERS=$(CONFIG_HEADER) \ - $(SHELL) ./config.status - @echo timestamp > stamp-h -$(srcdir)/$(CONFIG_HEADER_IN): stamp-h.in -$(srcdir)/stamp-h.in: $(top_srcdir)/configure.in $(ACLOCAL) acconfig.h - cd $(top_srcdir) && autoheader - echo timestamp > $(srcdir)/stamp-h.in - -mostlyclean-hdr: - -clean-hdr: - -distclean-hdr: - rm -f $(CONFIG_HEADER) - -maintainer-clean-hdr: -fd.h: $(top_builddir)/config.status fd.h.in - cd $(top_builddir) && CONFIG_FILES=$@ CONFIG_HEADERS= ./config.status -guile-snarf: $(top_builddir)/config.status guile-snarf.in - cd $(top_builddir) && CONFIG_FILES=$@ CONFIG_HEADERS= ./config.status - -mostlyclean-libLIBRARIES: - -clean-libLIBRARIES: - test -z "$(lib_LIBRARIES)" || rm -f $(lib_LIBRARIES) - -distclean-libLIBRARIES: - -maintainer-clean-libLIBRARIES: - -install-libLIBRARIES: $(lib_LIBRARIES) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(libdir) - list="$(lib_LIBRARIES)"; for p in $$list; do \ - if test -f $$p; then \ - echo "$(INSTALL_DATA) $$p $(libdir)/$$p"; \ - $(INSTALL_DATA) $$p $(libdir)/$$p; \ - else :; fi; \ - done - $(POST_INSTALL) - @list="$(lib_LIBRARIES)"; for p in $$list; do \ - if test -f $$p; then \ - echo "$(RANLIB) $(libdir)/$$p"; \ - $(RANLIB) $(libdir)/$$p; \ - else :; fi; \ - done - -uninstall-libLIBRARIES: - list="$(lib_LIBRARIES)"; for p in $$list; do \ - rm -f $(libdir)/$$p; \ - done - -.c.o: - $(COMPILE) -c $< - -mostlyclean-compile: - rm -f *.o core - -clean-compile: - -distclean-compile: - rm -f *.tab.c - -maintainer-clean-compile: -$(libguile_a_OBJECTS): scmconfig.h - -libguile.a: $(libguile_a_OBJECTS) $(libguile_a_DEPENDENCIES) - rm -f libguile.a - $(AR) cru libguile.a $(libguile_a_OBJECTS) $(libguile_a_LIBADD) - $(RANLIB) libguile.a - -install-binSCRIPTS: $(bin_SCRIPTS) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(bindir) - @list="$(bin_SCRIPTS)"; for p in $$list; do \ - if test -f $$p; then \ - echo "$(INSTALL_SCRIPT) $$p $(bindir)/`echo $$p|sed '$(transform)'`"; \ - $(INSTALL_SCRIPT) $$p $(bindir)/`echo $$p|sed '$(transform)'`; \ - else if test -f $(srcdir)/$$p; then \ - echo "$(INSTALL_SCRIPT) $(srcdir)/$$p $(bindir)/`echo $$p|sed '$(transform)'`"; \ - $(INSTALL_SCRIPT) $(srcdir)/$$p $(bindir)/`echo $$p|sed '$(transform)'`; \ - else :; fi; fi; \ - done - -uninstall-binSCRIPTS: - list="$(bin_SCRIPTS)"; for p in $$list; do \ - rm -f $(bindir)/`echo $$p|sed '$(transform)'`; \ - done - -install-modincludeDATA: $(modinclude_DATA) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(modincludedir) - @list="$(modinclude_DATA)"; for p in $$list; do \ - if test -f $(srcdir)/$$p; then \ - echo "$(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p"; \ - $(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p; \ - else if test -f $$p; then \ - echo "$(INSTALL_DATA) $$p $(modincludedir)/$$p"; \ - $(INSTALL_DATA) $$p $(modincludedir)/$$p; \ - fi; fi; \ - done - -uninstall-modincludeDATA: - list="$(modinclude_DATA)"; for p in $$list; do \ - rm -f $(modincludedir)/$$p; \ - done - -install-modincludeHEADERS: $(modinclude_HEADERS) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(modincludedir) - @list="$(modinclude_HEADERS)"; for p in $$list; do \ - echo "$(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p"; \ - $(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p; \ - done - -uninstall-modincludeHEADERS: - list="$(modinclude_HEADERS)"; for p in $$list; do \ - rm -f $(modincludedir)/$$p; \ - done - -install-includeHEADERS: $(include_HEADERS) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(includedir) - @list="$(include_HEADERS)"; for p in $$list; do \ - echo "$(INSTALL_DATA) $(srcdir)/$$p $(includedir)/$$p"; \ - $(INSTALL_DATA) $(srcdir)/$$p $(includedir)/$$p; \ - done - -uninstall-includeHEADERS: - list="$(include_HEADERS)"; for p in $$list; do \ - rm -f $(includedir)/$$p; \ - done - -tags: TAGS - -ID: $(HEADERS) $(SOURCES) - here=`pwd` && cd $(srcdir) && mkid -f$$here/ID $(SOURCES) $(HEADERS) - -TAGS: $(HEADERS) $(SOURCES) scmconfig.h.in $(TAGS_DEPENDENCIES) - tags=; \ - here=`pwd`; \ - list="$(SUBDIRS)"; for subdir in $$list; do \ - test -f $$subdir/TAGS && tags="$$tags -i $$here/$$subdir/TAGS"; \ - done; \ - test -z "$(ETAGS_ARGS)scmconfig.h.in$(SOURCES)$(HEADERS)$$tags" \ - || cd $(srcdir) && etags $(ETAGS_ARGS) $$tags scmconfig.h.in $(SOURCES) $(HEADERS) -o $$here/TAGS - -mostlyclean-tags: - -clean-tags: - -distclean-tags: - rm -f TAGS ID - -maintainer-clean-tags: - -distdir = $(PACKAGE)-$(VERSION) -# This target untars the dist file and tries a VPATH configuration. Then -# it guarantees that the distribution is self-contained by making another -# tarfile. -distcheck: dist - rm -rf $(distdir) - $(TAR) zxf $(distdir).tar.gz - mkdir $(distdir)/=build - mkdir $(distdir)/=inst - dc_install_base=`cd $(distdir)/=inst && pwd`; \ - cd $(distdir)/=build \ - && ../configure --srcdir=.. --prefix=$$dc_install_base \ - && $(MAKE) \ - && $(MAKE) dvi \ - && $(MAKE) check \ - && $(MAKE) install \ - && $(MAKE) installcheck \ - && $(MAKE) dist - rm -rf $(distdir) - @echo "========================"; \ - echo "$(distdir).tar.gz is ready for distribution"; \ - echo "========================" -dist: distdir - -chmod -R a+r $(distdir) - $(TAR) chozf $(distdir).tar.gz $(distdir) - rm -rf $(distdir) -dist-all: distdir - -chmod -R a+r $(distdir) - $(TAR) chozf $(distdir).tar.gz $(distdir) - rm -rf $(distdir) -distdir: $(DISTFILES) - rm -rf $(distdir) - mkdir $(distdir) - -chmod 755 $(distdir) - here=`pwd`; distdir=`cd $(distdir) && pwd` \ - && cd $(srcdir) \ - && automake --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --foreign - $(mkinstalldirs) $(distdir)/PLUGIN - @for file in $(DISTFILES); do \ - d=$(srcdir); \ - test -f $(distdir)/$$file \ - || ln $$d/$$file $(distdir)/$$file 2> /dev/null \ - || cp -p $$d/$$file $(distdir)/$$file; \ - done -.deps/.P: - test -d .deps || mkdir .deps - echo > $@ - --include $(DEP_FILES) -$(DEP_FILES): .deps/.P - -mostlyclean-depend: - -clean-depend: - -distclean-depend: - -maintainer-clean-depend: - rm -rf .deps - -.deps/%.P: $(srcdir)/%.c - @echo "Computing dependencies for $<..." - @o='o'; \ - test -n "$o" && o='$$o'; \ - $(MKDEP) $< | sed "s/^\(.*\)\.o:/\1.$$o \1.l$$o:/" > $@ -info: -dvi: -check: all - $(MAKE) -installcheck: -install-exec: install-libLIBRARIES install-binSCRIPTS - $(NORMAL_INSTALL) - -install-data: install-modincludeDATA install-modincludeHEADERS install-includeHEADERS - $(NORMAL_INSTALL) - -install: install-exec install-data all - @: - -uninstall: uninstall-libLIBRARIES uninstall-binSCRIPTS uninstall-modincludeDATA uninstall-modincludeHEADERS uninstall-includeHEADERS - -all: $(LIBRARIES) $(SCRIPTS) $(DATA) $(HEADERS) Makefile scmconfig.h - -install-strip: - $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install -installdirs: - $(mkinstalldirs) $(libdir) $(bindir) $(modincludedir) $(modincludedir) \ - $(includedir) - - -mostlyclean-generic: - test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) - -clean-generic: - test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) - -distclean-generic: - rm -f Makefile $(DISTCLEANFILES) - rm -f config.cache config.log stamp-h - test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -maintainer-clean-generic: - test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) - test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) -mostlyclean: mostlyclean-hdr mostlyclean-libLIBRARIES \ - mostlyclean-compile mostlyclean-tags mostlyclean-depend \ - mostlyclean-generic - -clean: clean-hdr clean-libLIBRARIES clean-compile clean-tags \ - clean-depend clean-generic mostlyclean - -distclean: distclean-hdr distclean-libLIBRARIES distclean-compile \ - distclean-tags distclean-depend distclean-generic clean - rm -f config.status - -maintainer-clean: maintainer-clean-hdr maintainer-clean-libLIBRARIES \ - maintainer-clean-compile maintainer-clean-tags \ - maintainer-clean-depend maintainer-clean-generic \ - distclean - @echo "This command is intended for maintainers to use;" - @echo "it deletes files that may require special tools to rebuild." - rm -f config.status - -.PHONY: default mostlyclean-hdr distclean-hdr clean-hdr \ -maintainer-clean-hdr mostlyclean-libLIBRARIES distclean-libLIBRARIES \ -clean-libLIBRARIES maintainer-clean-libLIBRARIES uninstall-libLIBRARIES \ -install-libLIBRARIES mostlyclean-compile distclean-compile \ -clean-compile maintainer-clean-compile uninstall-binSCRIPTS \ -install-binSCRIPTS uninstall-modincludeDATA install-modincludeDATA \ -uninstall-modincludeHEADERS install-modincludeHEADERS \ -uninstall-includeHEADERS install-includeHEADERS tags mostlyclean-tags \ -distclean-tags clean-tags maintainer-clean-tags distdir \ -mostlyclean-depend distclean-depend clean-depend \ -maintainer-clean-depend info dvi installcheck install-exec install-data \ -install uninstall all installdirs mostlyclean-generic distclean-generic \ -clean-generic maintainer-clean-generic clean mostlyclean distclean \ -maintainer-clean - - -libpath.h: Makefile - echo '/* generated by Makefile */' > libpath.h - echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.h - echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(VERSION)"' >> libpath.h - echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.h -.c.x: - ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@ - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff --git a/libguile/__scm.h b/libguile/__scm.h deleted file mode 100644 index 22c2eaa38..000000000 --- a/libguile/__scm.h +++ /dev/null @@ -1,432 +0,0 @@ -/* classes: h_files */ - -#ifndef __SCMH -#define __SCMH -/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* {Supported Options} - * - * These may be defined or undefined. - */ - -/* If the compile FLAG `CAUTIOUS' is #defined then the number of - * arguments is always checked for application of closures. If the - * compile FLAG `RECKLESS' is #defined then they are not checked. - * Otherwise, number of argument checks for closures are made only when - * the function position (whose value is the closure) of a combination is - * not an ILOC or GLOC. When the function position of a combination is a - * symbol it will be checked only the first time it is evaluated because - * it will then be replaced with an ILOC or GLOC. - */ -#undef RECKLESS -#define CAUTIOUS - -/* After looking up a local for the first time, rewrite the - * code graph, caching its position. - */ -#define MEMOIZE_LOCALS - -/* All the number support there is. - */ -#define SCM_FLOATS -#define BIGNUMS - -/* GC should relinquish empty cons-pair arenas. - */ -#define GC_FREE_SEGMENTS - -/* Provide a scheme-accessible count-down timer that - * generates a pseudo-interrupt. - */ -#define TICKS - - -/* Use engineering notation when converting numbers strings? - */ -#undef ENGNOT - -/* Include support for uniform arrays? - * - * Possibly some of the initialization code depends on this - * being defined, but that is a bug and should be fixed. - */ -#define ARRAYS - -#undef SCM_CAREFUL_INTS - -/* {Unsupported Options} - * - * These must be defined as given here. - */ - - -#define CCLO - -/* Guile Scheme supports the #f/() distinction; Guile Lisp won't. We - have horrible plans for their unification. */ -#undef SICP - - - -/* Random options (not yet supported or in final form). */ - -#define STACK_CHECKING -#undef NO_CEVAL_STACK_CHECKING -#undef LONGLONGS - -/* Some auto-generated .h files contain unused prototypes - * that need these typedefs. - */ -typedef long long_long; -typedef unsigned long ulong_long; - - - -/* What did the configure script discover about the outside world? */ -#include "libguile/scmconfig.h" - - -/* Write prototype declarations like this: - int foo SCM_P ((int a, int b)); - At definitions, use K&R style declarations, but make sure there's a - declarative prototype (as above) in scope. This will give you - argument type checking, when available, and be harmless otherwise. */ -#ifdef __STDC__ -# define SCM_P(x) x -#else -# define SCM_P(x) () -#endif - - - -/* Define - * - * SCM_CHAR_CODE_LIMIT == UCHAR_MAX + 1 - * SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2) - * SCM_MOST_NEGATIVE_FIXNUM == SCM_SRS((long)LONG_MIN, 2) - */ - -#ifdef HAVE_LIMITS_H -# include <limits.h> -# ifdef UCHAR_MAX -# define SCM_CHAR_CODE_LIMIT (UCHAR_MAX+1L) -# else -# define SCM_CHAR_CODE_LIMIT 256L -# endif /* def UCHAR_MAX */ -# define SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2) -# ifdef _UNICOS /* Stupid cray bug */ -# define SCM_MOST_NEGATIVE_FIXNUM ((long)LONG_MIN/4) -# else -# define SCM_MOST_NEGATIVE_FIXNUM SCM_SRS((long)LONG_MIN, 2) -# endif /* UNICOS */ -#else -# define SCM_CHAR_CODE_LIMIT 256L -# define SCM_MOST_POSITIVE_FIXNUM ((long)((unsigned long)~0L>>3)) -# if (0 != ~0) -# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1) -# else -# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM) -# endif /* (0 != ~0) */ -#endif /* def HAVE_LIMITS_H */ - - -#ifdef STDC_HEADERS -# include <stdlib.h> -# ifdef AMIGA -# include <stddef.h> -# endif /* def AMIGA */ -# define scm_sizet size_t -#else -# ifdef _SIZE_T -# define scm_sizet size_t -# else -# define scm_sizet unsigned int -# endif /* def _SIZE_T */ -#endif /* def STDC_HEADERS */ - - - -#include "libguile/tags.h" - - -#ifdef vms -# ifndef CHEAP_CONTINUATIONS - typedef int jmp_buf[17]; - extern int setjump(jmp_buf env); - extern int longjump(jmp_buf env, int ret); -# define setjmp setjump -# define longjmp longjump -# else -# include <setjmp.h> -# endif -#else /* ndef vms */ -# ifdef _CRAY1 - typedef int jmp_buf[112]; - extern int setjump(jmp_buf env); - extern int longjump(jmp_buf env, int ret); -# define setjmp setjump -# define longjmp longjump -# else /* ndef _CRAY1 */ -# include <setjmp.h> -# endif /* ndef _CRAY1 */ -#endif /* ndef vms */ - -/* James Clark came up with this neat one instruction fix for - * continuations on the SPARC. It flushes the register windows so - * that all the state of the process is contained in the stack. - */ - -#ifdef sparc -# define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3") -#else -# define SCM_FLUSH_REGISTER_WINDOWS /* empty */ -#endif - -/* If stack is not longword aligned then - */ - -/* #define SHORT_ALIGN */ -#ifdef THINK_C -# define SHORT_ALIGN -#endif -#ifdef MSDOS -# define SHORT_ALIGN -#endif -#ifdef atarist -# define SHORT_ALIGN -#endif - -#ifdef SHORT_ALIGN -typedef short SCM_STACKITEM; -#else -typedef long SCM_STACKITEM; -#endif - - -#ifndef USE_THREADS -#define SCM_THREAD_DEFER -#define SCM_THREAD_ALLOW -#define SCM_THREAD_REDEFER -#define SCM_THREAD_REALLOW_1 -#define SCM_THREAD_REALLOW_2 -#define SCM_THREAD_SWITCHING_CODE -#endif - -extern unsigned int scm_async_clock; -#if 0 -#define SCM_ASYNC_TICK \ -{ \ - if (0 == --scm_async_clock) \ - scm_async_click (); \ -} \ - -#else -#define SCM_ASYNC_TICK \ -{ \ - if (0 == --scm_async_clock) \ - scm_async_click (); \ - SCM_THREAD_SWITCHING_CODE; \ -} \ - -#endif - -#ifdef SCM_CAREFUL_INTS -#define SCM_CHECK_NOT_DISABLED \ - if (scm_ints_disabled) \ - fputs("ints already disabled\n", stderr); \ - -#define SCM_CHECK_NOT_ENABLED \ - if (!scm_ints_disabled) \ - fputs("ints already enabled\n", stderr); \ - -#else -#define SCM_CHECK_NOT_DISABLED -#define SCM_CHECK_NOT_ENABLED -#endif - - -#define SCM_DEFER_INTS \ -{ \ - SCM_CHECK_NOT_DISABLED; \ - SCM_THREAD_DEFER; \ - scm_ints_disabled = 1; \ -} \ - - -#define SCM_ALLOW_INTS_ONLY \ -{ \ - SCM_THREAD_ALLOW; \ - scm_ints_disabled = 0; \ -} \ - - -#define SCM_ALLOW_INTS \ -{ \ - SCM_CHECK_NOT_ENABLED; \ - SCM_THREAD_ALLOW; \ - scm_ints_disabled = 0; \ - SCM_ASYNC_TICK; \ -} \ - - -#define SCM_REDEFER_INTS \ -{ \ - SCM_THREAD_REDEFER; \ - ++scm_ints_disabled; \ -} \ - - -#define SCM_REALLOW_INTS \ -{ \ - SCM_THREAD_REALLOW_1; \ - --scm_ints_disabled; \ - if (!scm_ints_disabled) \ - { \ - SCM_THREAD_REALLOW_2; \ - SCM_ASYNC_TICK; \ - } \ -} \ - - - - - -/** SCM_ASSERT - ** - **/ - - -#ifdef SCM_RECKLESS -#define SCM_ASSERT(_cond, _arg, _pos, _subr) -#define SCM_ASRTGO(_cond, _label) -#else -#define SCM_ASSERT(_cond, _arg, _pos, _subr) \ - if (!(_cond)) \ - scm_wta(_arg, (char *)(_pos), _subr) -#define SCM_ASRTGO(_cond, _label) \ - if (!(_cond)) \ - goto _label -#endif - -#define SCM_ARGn 0 -#define SCM_ARG1 1 -#define SCM_ARG2 2 -#define SCM_ARG3 3 -#define SCM_ARG4 4 -#define SCM_ARG5 5 - /* #define SCM_ARG6 6 - #define SCM_ARG7 7 */ - /* #define SCM_ARGERR(X) ((X) < SCM_WNA \ - ? (char *)(X) \ - : "wrong type argument") - */ - -/* Following must match entry indexes in scm_errmsgs[]. - * Also, SCM_WNA must follow the last SCM_ARGn in sequence. - */ -#define SCM_WNA 8 - /* #define SCM_OVSCM_FLOW 9 */ -#define SCM_OUTOFRANGE 10 -#define SCM_NALLOC 11 - /* #define SCM_STACK_OVFLOW 12 */ - /* #define SCM_EXIT 13 */ - - -/* (...still matching scm_errmsgs) These - * are signals. Signals may become errors - * but are distinguished because they first - * try to invoke a handler that can resume - * the interrupted routine. - */ -#define SCM_HUP_SIGNAL 14 -#define SCM_INT_SIGNAL 15 -#define SCM_FPE_SIGNAL 16 -#define SCM_BUS_SIGNAL 17 -#define SCM_SEGV_SIGNAL 18 -#define SCM_ALRM_SIGNAL 19 -#define SCM_GC_SIGNAL 20 -#define SCM_TICK_SIGNAL 21 - -#define SCM_SIG_ORD(X) ((X) - SCM_HUP_SIGNAL) -#define SCM_ORD_SIG(X) ((X) + SCM_HUP_SIGNAL) -#define SCM_NUM_SIGS (SCM_SIG_ORD (SCM_TICK_SIGNAL) + 1) - -#if 0 -struct errdesc -{ - char *msg; - char *s_response; - short parent_err; -}; - - -extern struct errdesc scm_errmsgs[]; -#endif - - - -/* SCM_EXIT_SUCCESS is the default code to return from SCM if no errors - * were encountered. SCM_EXIT_FAILURE is the default code to return from - * SCM if errors were encountered. The return code can be explicitly - * specified in a SCM program with (scm_quit <n>). - */ - -#ifndef SCM_EXIT_SUCCESS -#ifdef vms -#define SCM_EXIT_SUCCESS 1 -#else -#define SCM_EXIT_SUCCESS 0 -#endif /* def vms */ -#endif /* ndef SCM_EXIT_SUCCESS */ -#ifndef SCM_EXIT_FAILURE -#ifdef vms -#define SCM_EXIT_FAILURE 2 -#else -#define SCM_EXIT_FAILURE 1 -#endif /* def vms */ -#endif /* ndef SCM_EXIT_FAILURE */ - - - - - -#endif /* __SCMH */ diff --git a/libguile/_scm.h b/libguile/_scm.h deleted file mode 100644 index 88d771a0a..000000000 --- a/libguile/_scm.h +++ /dev/null @@ -1,124 +0,0 @@ -/* classes: h_files */ - -#ifndef _SCMH -#define _SCMH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "__scm.h" - -/* This file is only visible to the libguile sources */ - -/* Include headers for those files central to the implementation. The - rest should be explicitly #included in the C files themselves. */ -#include "error.h" /* Everyone signals errors. */ -#include "print.h" /* Everyone needs to print. */ -#include "pairs.h" /* Everyone conses. */ -#include "list.h" /* Everyone makes lists. */ -#include "gc.h" /* Everyone allocates. */ -#include "gsubr.h" /* Everyone defines global functions. */ -#include "procs.h" /* Same. */ -#include "numbers.h" /* Everyone deals with fixnums. */ -#include "symbols.h" /* For length, chars, values, miscellany. */ -#include "boolean.h" /* Everyone wonders about the truth. */ -#include "strings.h" /* Everyone loves string. */ -#include "vectors.h" /* Vectors are used for structures a lot. */ -#include "root.h" /* Everyone uses these objects. */ -#include "ports.h" /* Everyone does I/O. */ -#include "async.h" /* Everyone allows/disallows ints. */ -#ifdef USE_THREADS -#include "../threads/threads.h" /* Some thread packages does switching - at async ticks. */ -#endif -#include "snarf.h" /* Everyone snarfs. */ - -/* On VMS, GNU C's errno.h contains a special hack to get link attributes - * for errno correct for linking to the C RTL. - */ -#include <errno.h> - -/* SCM_SYSCALL retries system calls that have been interrupted (EINTR) */ -#ifdef vms -# ifndef __GNUC__ -# include <ssdef.h> -# define SCM_SYSCALL(line) do{errno = 0;line;} \ - while(EVMSERR==errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3)) -# endif /* ndef __GNUC__ */ -#endif /* def vms */ - -#ifndef SCM_SYSCALL -# ifdef EINTR -# if (EINTR > 0) -# define SCM_SYSCALL(line) do{errno = 0;line;}while(EINTR==errno) -# endif /* (EINTR > 0) */ -# endif /* def EINTR */ -#endif /* ndef SCM_SYSCALL */ - -#ifndef SCM_SYSCALL -# define SCM_SYSCALL(line) {line;} -#endif /* ndef SCM_SYSCALL */ - -#ifndef MSDOS -# ifdef ARM_ULIB - extern volatile int errno; -# else - extern int errno; -# endif /* def ARM_ULIB */ -#endif /* ndef MSDOS */ -#ifdef __TURBOC__ -# if (__TURBOC__==1) - /* Needed for TURBOC V1.0 */ - extern int errno; -# endif /* (__TURBOC__==1) */ -#endif /* def __TURBOC__ */ - - - -#ifndef min -#define min(A,B) ((A) <= (B) ? (A) : (B)) -#endif -#ifndef max -#define max(A,B) ((A) >= (B) ? (A) : (B)) -#endif - -#endif /* _SCMH */ - diff --git a/libguile/acconfig.h b/libguile/acconfig.h deleted file mode 100644 index ded2b044b..000000000 --- a/libguile/acconfig.h +++ /dev/null @@ -1,81 +0,0 @@ -/* acconfig.h --- documentation for symbols possibly defined in scmconfig.h - Jim Blandy <jimb@cyclic.com> --- August 1996 */ - -/* Define these two if you want support for debugging of Scheme - programs. */ -#undef DEBUG_EXTENSIONS -#undef READER_EXTENSIONS - -/* Define this if your system has a way to set a stdio stream's file - descriptor. You should also copy fd.h.in to fd.h, and give the - macro SET_FILE_FD_FIELD an appropriate definition. See - configure.in for more details. */ -#undef HAVE_FD_SETTER - -/* Define this if your system has a way to set a stdio stream's file - descriptor. You should also copy fd.h.in to fd.h, and give the - macro SET_FILE_FD_FIELD an appropriate definition. See - configure.in for more details. */ -#undef HAVE_FD_SETTER - -/* Set this to the name of a field in FILE which contains the number - of buffered characters waiting to be read. */ -#undef FILE_CNT_FIELD - -/* Define this if your stdio has _gptr and _egptr fields which can - be compared to give the number of buffered characters waiting to - be read. */ -#undef FILE_CNT_GPTR - -/* Define this if your stdio has _IO_read_ptr and _IO_read_end fields - which can be compared to give the number of buffered characters - waiting to be read. */ -#undef FILE_CNT_READPTR - -/* Define this if your system defines struct linger, for use with the - getsockopt and setsockopt system calls. */ -#undef HAVE_STRUCT_LINGER - -/* Define this if floats are the same size as longs. */ -#undef SCM_SINGLES - -/* Define this if a callee's stack frame has a higher address than the - caller's stack frame. On most machines, this is not the case. */ -#undef SCM_STACK_GROWS_UP - -/* Define this if <utime.h> doesn't define struct utimbuf unless - _POSIX_SOURCE is #defined. See GUILE_STRUCT_UTIMBUF in aclocal.m4. */ -#undef UTIMBUF_NEEDS_POSIX - -/* Define this if we should #include <libc.h> when we've already - #included <unistd.h>. On some systems, they conflict, and libc.h - should be omitted. See GUILE_HEADER_LIBC_WITH_UNISTD in - aclocal.m4. */ -#undef LIBC_H_WITH_UNISTD_H - -/* Define these to indicate the current version of Guile. These - values are supposed to be supplied by the configuration system. */ -#undef GUILE_MAJOR_VERSION -#undef GUILE_MINOR_VERSION -#undef GUILE_VERSION - -/* Define if using cooperative multithreading. */ -#undef USE_COOP_THREADS - -/* Define if using "FSU" pthreads. */ -#undef USE_FSU_PTHREADS - -/* Define if using MIT pthreads. */ -#undef USE_MIT_PTHREADS - -/* Define if using PCthreads pthreads. */ -#undef USE_PCTHREADS_PTHREADS - -/* Define if using any sort of threads. */ -#undef USE_THREADS - -/* Name of this package. */ -#undef PACKAGE - -/* Define if you want support for dynamic linking. */ -#undef DYNAMIC_LINKING diff --git a/libguile/acinclude.m4 b/libguile/acinclude.m4 deleted file mode 100644 index e69de29bb..000000000 --- a/libguile/acinclude.m4 +++ /dev/null diff --git a/libguile/aclocal.m4 b/libguile/aclocal.m4 deleted file mode 100644 index 0ddeceb4f..000000000 --- a/libguile/aclocal.m4 +++ /dev/null @@ -1,240 +0,0 @@ -dnl aclocal.m4 generated automatically by aclocal 1.1l - -dnl On the NeXT, #including <utime.h> doesn't give you a definition for -dnl struct utime, unless you #define _POSIX_SOURCE. - -AC_DEFUN(GUILE_STRUCT_UTIMBUF, [ - AC_CACHE_CHECK([whether we need POSIX to get struct utimbuf], - guile_cv_struct_utimbuf_needs_posix, - [AC_TRY_CPP([ -#ifdef __EMX__ -#include <sys/utime.h> -#else -#include <utime.h> -#endif -struct utime blah; -], - guile_cv_struct_utimbuf_needs_posix=no, - guile_cv_struct_utimbuf_needs_posix=yes)]) - if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then - AC_DEFINE(UTIMBUF_NEEDS_POSIX) - fi]) - - - - -dnl -dnl Apparently, at CMU they have a weird version of libc.h that is -dnl installed in /usr/local/include and conflicts with unistd.h. -dnl In these situations, we should not #include libc.h. -dnl This test arranges to #define LIBC_H_WITH_UNISTD_H iff libc.h is -dnl present on the system, and is safe to #include. -dnl -AC_DEFUN([GUILE_HEADER_LIBC_WITH_UNISTD], - [ - AC_CHECK_HEADERS(libc.h unistd.h) - AC_CACHE_CHECK( - "whether libc.h and unistd.h can be included together", - guile_cv_header_libc_with_unistd, - [ - if test "$ac_cv_header_libc_h" = "no"; then - guile_cv_header_libc_with_unistd="no" - elif test "$ac_cv_header_unistd.h" = "no"; then - guile_cv_header_libc_with_unistd="yes" - else - AC_TRY_COMPILE( - [ -# include <libc.h> -# include <unistd.h> - ], - [], - [guile_cv_header_libc_with_unistd=yes], - [guile_cv_header_libc_with_unistd=no] - ) - fi - ] - ) - if test "$guile_cv_header_libc_with_unistd" = yes; then - AC_DEFINE(LIBC_H_WITH_UNISTD_H) - fi - ] -) - -# Like AC_CONFIG_HEADER, but automatically create stamp file. - -AC_DEFUN(AM_CONFIG_HEADER, -[AC_PREREQ([2.12]) -AC_CONFIG_HEADER([$1]) -dnl When config.status generates a header, we must update the stamp-h file. -dnl This file resides in the same directory as the config header -dnl that is generated. We must strip everything past the first ":", -dnl and everything past the last "/". -AC_OUTPUT_COMMANDS(changequote(<<,>>)dnl -test -z "<<$>>CONFIG_HEADER" || echo timestamp > patsubst(<<$1>>, <<^\([^:]*/\)?.*>>, <<\1>>)stamp-h<<>>dnl -changequote([,]))]) - - -dnl Usage: AM_INIT_GUILE_MODULE(module-name) -dnl This macro will automatically get the guile version from the -dnl top-level srcdir, and will initialize automake. It also -dnl defines the `module' variable. -AC_DEFUN([AM_INIT_GUILE_MODULE],[ -. $srcdir/../GUILE-VERSION -AM_INIT_AUTOMAKE($PACKAGE, $VERSION) -AC_CONFIG_AUX_DIR(..) -module=[$1] -AC_SUBST(module)]) - -# Do all the work for Automake. This macro actually does too much -- -# some checks are only needed if your package does certain things. -# But this isn't really a big deal. - -# serial 1 - -dnl Usage: -dnl AM_INIT_AUTOMAKE(package,version) - -AC_DEFUN(AM_INIT_AUTOMAKE, -[AC_REQUIRE([AM_PROG_INSTALL]) -PACKAGE=[$1] -AC_SUBST(PACKAGE) -AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE") -VERSION=[$2] -AC_SUBST(VERSION) -AC_DEFINE_UNQUOTED(VERSION, "$VERSION") -AM_SANITY_CHECK -AC_ARG_PROGRAM -AC_PROG_MAKE_SET]) - - -# serial 1 - -AC_DEFUN(AM_PROG_INSTALL, -[AC_REQUIRE([AC_PROG_INSTALL]) -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' -AC_SUBST(INSTALL_SCRIPT)dnl -]) - -# -# Check to make sure that the build environment is sane. -# - -AC_DEFUN(AM_SANITY_CHECK, -[AC_MSG_CHECKING([whether build environment is sane]) -echo timestamp > conftestfile -# Do this in a subshell so we don't clobber the current shell's -# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? -if (set X `ls -t $srcdir/configure conftestfile`; test "[$]2" = conftestfile) -then - # Ok. - : -else - AC_MSG_ERROR([newly created file is older than distributed files! -Check your system clock]) -fi -rm -f conftest* -AC_MSG_RESULT(yes)]) - -dnl -dnl CY_AC_WITH_THREADS determines which thread library the user intends -dnl to put underneath guile. Pass it the path to find the guile top-level -dnl source directory. Eg CY_AC_WITH_THREADS(../..) for tcl/unix. -dnl - -AC_DEFUN([CY_AC_WITH_THREADS],[ -AC_CACHE_CHECK("threads package type",cy_cv_threads_package,[ -AC_CACHE_VAL(cy_cv_threads_cflags,[ -AC_CACHE_VAL(cy_cv_threads_libs,[ -use_threads=no; -AC_ARG_WITH(threads,[ --with-threads thread interface], - use_threads=$withval, use_threads=no) -test -n "$use_threads" || use_threads=qt -threads_package=unknown -if test "$use_threads" != no; then -dnl -dnl Test for the qt threads package - used for cooperative threads -dnl This may not necessarily be built yet - so just check for the -dnl header files. -dnl - if test "$use_threads" = yes || test "$use_threads" = qt; then - # Look for qt in source directory. This is a hack: we look in - # "./qt" because this check might be run at the top level. - if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then - threads_package=COOP - cy_cv_threads_cflags="-I$srcdir/../qt -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - else - if test -f $use_threads/qt.c; then - # FIXME seems as though we should try to use an installed qt here. - threads_package=COOP - cy_cv_threads_cflags="-I$use_threads -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - fi - if test "$use_threads" = pthreads; then - # Look for pthreads in srcdir. See above to understand why - # we always set threads_package. - if test -f $srcdir/../../pthreads/pthreads/queue.c \ - || test -f $srcdir/../pthreads/pthreads/queue.c; then - threads_package=MIT - cy_cv_threads_cflags="-I$srcdir/../../pthreads/include" - cy_cv_threads_libs="-L../../pthreads/lib -lpthread" - fi - fi - saved_CPP="$CPPFLAGS" - saved_LD="$LDFLAGS" - saved_LIBS="$LIBS" - if test "$threads_package" = unknown; then -dnl -dnl Test for the FSU threads package -dnl - CPPFLAGS="-I$use_threads/include" - LDFLAGS="-L$use_threads/lib" - LIBS="-lgthreads -lmalloc" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=FSU) - fi - if test "$threads_package" = unknown; then -dnl -dnl Test for the MIT threads package -dnl - LIBS="-lpthread" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=MIT) - fi - if test "$threads_package" = unknown; then -dnl -dnl Test for the PCthreads package -dnl - LIBS="-lpthreads" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=PCthreads) - fi -dnl -dnl Set the appropriate flags! -dnl - cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags" - cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs" - cy_cv_threads_package=$threads_package - CPPFLAGS="$saved_CPP" - LDFLAGS="$saved_LD" - LIBS="$saved_LIBS" - if test "$threads_package" = unknown; then - AC_MSG_ERROR("cannot find thread library installation") - fi -fi -]) -]) -], -dnl -dnl Set flags according to what is cached. -dnl -CPPFLAGS="$cy_cv_threads_cflags" -LIBS="$cy_cv_threads_libs" -) -]) - diff --git a/libguile/alist.c b/libguile/alist.c deleted file mode 100644 index 06ede611a..000000000 --- a/libguile/alist.c +++ /dev/null @@ -1,380 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "eq.h" -#include "list.h" - -#include "alist.h" - - - -SCM_PROC(s_acons, "acons", 3, 0, 0, scm_acons); - -SCM -scm_acons (w, x, y) - SCM w; - SCM x; - SCM y; -{ - register SCM z; - SCM_NEWCELL (z); - SCM_SETCAR (z, w); - SCM_SETCDR (z, x); - x = z; - SCM_NEWCELL (z); - SCM_SETCAR (z, x); - SCM_SETCDR (z, y); - return z; -} - - - -SCM_PROC (s_sloppy_assq, "sloppy-assq", 2, 0, 0, scm_sloppy_assq); - -SCM -scm_sloppy_assq(x, alist) - SCM x; - SCM alist; -{ - - for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist)) - { - SCM tmp = SCM_CAR(alist); - if (SCM_NIMP (tmp) && SCM_CONSP (tmp) && (SCM_CAR (tmp)==x)) - return tmp; - } - return SCM_BOOL_F; -} - - - -SCM_PROC (s_sloppy_assv, "sloppy-assv", 2, 0, 0, scm_sloppy_assv); - -SCM -scm_sloppy_assv(x, alist) - SCM x; - SCM alist; -{ - for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist)) - { - SCM tmp = SCM_CAR(alist); - if (SCM_NIMP (tmp) - && SCM_CONSP (tmp) - && SCM_NFALSEP (scm_eqv_p (SCM_CAR (tmp), x))) - return tmp; - } - return SCM_BOOL_F; -} - - -SCM_PROC (s_sloppy_assoc, "sloppy-assoc", 2, 0, 0, scm_sloppy_assoc); - -SCM -scm_sloppy_assoc(x, alist) - SCM x; - SCM alist; -{ - for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist)) - { - SCM tmp = SCM_CAR(alist); - if (SCM_NIMP (tmp) - && SCM_CONSP (tmp) - && SCM_NFALSEP (scm_equal_p (SCM_CAR (tmp), x))) - return tmp; - } - return SCM_BOOL_F; -} - - - - -SCM_PROC(s_assq, "assq", 2, 0, 0, scm_assq); - -SCM -scm_assq(x, alist) - SCM x; - SCM alist; -{ - SCM tmp; - for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) { - SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assq); - tmp = SCM_CAR(alist); - SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assq); - if (SCM_CAR(tmp)==x) return tmp; - } - SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assq); - return SCM_BOOL_F; -} - - -SCM_PROC(s_assv, "assv", 2, 0, 0, scm_assv); - -SCM -scm_assv(x, alist) - SCM x; - SCM alist; -{ - SCM tmp; - for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) { - SCM_ASRTGO(SCM_CONSP(alist), badlst); - tmp = SCM_CAR(alist); - SCM_ASRTGO(SCM_NIMP(tmp) && SCM_CONSP(tmp), badlst); - if SCM_NFALSEP(scm_eqv_p(SCM_CAR(tmp), x)) return tmp; - } -# ifndef RECKLESS - if (!(SCM_NULLP(alist))) - badlst: scm_wta(alist, (char *)SCM_ARG2, s_assv); -# endif - return SCM_BOOL_F; -} - - -SCM_PROC(s_assoc, "assoc", 2, 0, 0, scm_assoc); - -SCM -scm_assoc(x, alist) - SCM x; - SCM alist; -{ - SCM tmp; - for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) { - SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assoc); - tmp = SCM_CAR(alist); - SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assoc); - if SCM_NFALSEP(scm_equal_p(SCM_CAR(tmp), x)) return tmp; - } - SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assoc); - return SCM_BOOL_F; -} - - - - -SCM_PROC (s_assq_ref, "assq-ref", 2, 0, 0, scm_assq_ref); - -SCM -scm_assq_ref (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assq (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return SCM_CDR (handle); - } - return SCM_BOOL_F; -} - - -SCM_PROC (s_assv_ref, "assv-ref", 2, 0, 0, scm_assv_ref); - -SCM -scm_assv_ref (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assv (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return SCM_CDR (handle); - } - return SCM_BOOL_F; -} - - -SCM_PROC (s_assoc_ref, "assoc-ref", 2, 0, 0, scm_assoc_ref); - -SCM -scm_assoc_ref (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assoc (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return SCM_CDR (handle); - } - return SCM_BOOL_F; -} - - - - - - -SCM_PROC (s_assq_set_x, "assq-set!", 3, 0, 0, scm_assq_set_x); - -SCM -scm_assq_set_x (alist, key, val) - SCM alist; - SCM key; - SCM val; -{ - SCM handle; - - handle = scm_sloppy_assq (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - SCM_SETCDR (handle, val); - return alist; - } - else - return scm_acons (key, val, alist); -} - -SCM_PROC (s_assv_set_x, "assv-set!", 3, 0, 0, scm_assv_set_x); - -SCM -scm_assv_set_x (alist, key, val) - SCM alist; - SCM key; - SCM val; -{ - SCM handle; - - handle = scm_sloppy_assv (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - SCM_SETCDR (handle, val); - return alist; - } - else - return scm_acons (key, val, alist); -} - -SCM_PROC (s_assoc_set_x, "assoc-set!", 3, 0, 0, scm_assoc_set_x); - -SCM -scm_assoc_set_x (alist, key, val) - SCM alist; - SCM key; - SCM val; -{ - SCM handle; - - handle = scm_sloppy_assoc (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - SCM_SETCDR (handle, val); - return alist; - } - else - return scm_acons (key, val, alist); -} - - - - -SCM_PROC (s_assq_remove_x, "assq-remove!", 2, 0, 0, scm_assq_remove_x); - -SCM -scm_assq_remove_x (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assq (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return scm_delq_x (handle, alist); - } - else - return alist; -} - - -SCM_PROC (s_assv_remove_x, "assv-remove!", 2, 0, 0, scm_assv_remove_x); - -SCM -scm_assv_remove_x (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assv (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return scm_delv_x (handle, alist); - } - else - return alist; -} - - -SCM_PROC (s_assoc_remove_x, "assoc-remove!", 2, 0, 0, scm_assoc_remove_x); - -SCM -scm_assoc_remove_x (alist, key) - SCM alist; - SCM key; -{ - SCM handle; - - handle = scm_sloppy_assoc (key, alist); - if (SCM_NIMP (handle) && SCM_CONSP (handle)) - { - return scm_delete_x (handle, alist); - } - else - return alist; -} - - - - - - -void -scm_init_alist () -{ -#include "alist.x" -} - diff --git a/libguile/alist.h b/libguile/alist.h deleted file mode 100644 index 87e327fdd..000000000 --- a/libguile/alist.h +++ /dev/null @@ -1,69 +0,0 @@ -/* classes: h_files */ - -#ifndef ALISTH -#define ALISTH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_acons SCM_P ((SCM w, SCM x, SCM y)); -extern SCM scm_sloppy_assq SCM_P ((SCM x, SCM alist)); -extern SCM scm_sloppy_assv SCM_P ((SCM x, SCM alist)); -extern SCM scm_sloppy_assoc SCM_P ((SCM x, SCM alist)); -extern SCM scm_assq SCM_P ((SCM x, SCM alist)); -extern SCM scm_assv SCM_P ((SCM x, SCM alist)); -extern SCM scm_assoc SCM_P ((SCM x, SCM alist)); -extern SCM scm_assq_ref SCM_P ((SCM alist, SCM key)); -extern SCM scm_assv_ref SCM_P ((SCM alist, SCM key)); -extern SCM scm_assoc_ref SCM_P ((SCM alist, SCM key)); -extern SCM scm_assq_set_x SCM_P ((SCM alist, SCM key, SCM val)); -extern SCM scm_assv_set_x SCM_P ((SCM alist, SCM key, SCM val)); -extern SCM scm_assoc_set_x SCM_P ((SCM alist, SCM key, SCM val)); -extern SCM scm_assq_remove_x SCM_P ((SCM alist, SCM key)); -extern SCM scm_assv_remove_x SCM_P ((SCM alist, SCM key)); -extern SCM scm_assoc_remove_x SCM_P ((SCM alist, SCM key)); -extern void scm_init_alist SCM_P ((void)); - -#endif /* ALISTH */ diff --git a/libguile/append.c b/libguile/append.c deleted file mode 100644 index 204d57ab8..000000000 --- a/libguile/append.c +++ /dev/null @@ -1,78 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "list.h" - -#include "append.h" - - - -SCM_PROC (s_append, "append", 0, 0, 1, scm_append); - -SCM -scm_append (objs) - SCM objs; -{ - return scm_list_append (objs); -} - - -SCM_PROC (s_append_x, "append!", 0, 0, 1, scm_append_x); - -SCM -scm_append_x (objs) - SCM objs; -{ - return scm_list_append_x (objs); -} - - - - -void -scm_init_append () -{ -#include "append.x" -} - diff --git a/libguile/append.h b/libguile/append.h deleted file mode 100644 index 9c13d6356..000000000 --- a/libguile/append.h +++ /dev/null @@ -1,55 +0,0 @@ -/* classes: h_files */ - -#ifndef APPENDH -#define APPENDH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_append SCM_P ((SCM objs)); -extern SCM scm_append_x SCM_P ((SCM objs)); -extern void scm_init_append SCM_P ((void)); - -#endif /* APPENDH */ diff --git a/libguile/appinit.c b/libguile/appinit.c deleted file mode 100644 index 1dff367f3..000000000 --- a/libguile/appinit.c +++ /dev/null @@ -1,52 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - - - - -void -scm_appinit () -{ -} diff --git a/libguile/arbiters.c b/libguile/arbiters.c deleted file mode 100644 index 292f4fec1..000000000 --- a/libguile/arbiters.c +++ /dev/null @@ -1,133 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "smob.h" - -#include "arbiters.h" - - -/* {Arbiters} - * - * These procedures implement synchronization primitives. Processors - * with an atomic test-and-set instruction can use it here (and not - * SCM_DEFER_INTS). - */ - -static long scm_tc16_arbiter; - - -static int -prinarb (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<arbiter ", port); - if (SCM_CAR (exp) & (1L << 16)) - scm_gen_puts (scm_regular_string, "locked ", port); - scm_iprin1 (SCM_CDR (exp), port, pstate); - scm_gen_putc ('>', port); - return !0; -} - -static scm_smobfuns arbsmob = -{ - scm_markcdr, scm_free0, prinarb, 0 -}; - -SCM_PROC(s_make_arbiter, "make-arbiter", 1, 0, 0, scm_make_arbiter); - -SCM -scm_make_arbiter (name) - SCM name; -{ - register SCM z; - SCM_NEWCELL (z); - SCM_SETCDR (z, name); - SCM_SETCAR (z, scm_tc16_arbiter); - return z; -} - -SCM_PROC(s_try_arbiter, "try-arbiter", 1, 0, 0, scm_try_arbiter); - -SCM -scm_try_arbiter (arb) - SCM arb; -{ - SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_try_arbiter); - SCM_DEFER_INTS; - if (SCM_CAR (arb) & (1L << 16)) - arb = SCM_BOOL_F; - else - { - SCM_SETCAR (arb, scm_tc16_arbiter | (1L << 16)); - arb = SCM_BOOL_T; - } - SCM_ALLOW_INTS; - return arb; -} - - -SCM_PROC(s_release_arbiter, "release-arbiter", 1, 0, 0, scm_release_arbiter); - -SCM -scm_release_arbiter (arb) - SCM arb; -{ - SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_release_arbiter); - if (!(SCM_CAR (arb) & (1L << 16))) - return SCM_BOOL_F; - SCM_SETCAR (arb, scm_tc16_arbiter); - return SCM_BOOL_T; -} - - - -void -scm_init_arbiters () -{ - scm_tc16_arbiter = scm_newsmob (&arbsmob); -#include "arbiters.x" -} - diff --git a/libguile/arbiters.h b/libguile/arbiters.h deleted file mode 100644 index 5e34ce297..000000000 --- a/libguile/arbiters.h +++ /dev/null @@ -1,56 +0,0 @@ -/* classes: h_files */ - -#ifndef ARBITERSH -#define ARBITERSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_make_arbiter SCM_P ((SCM name)); -extern SCM scm_try_arbiter SCM_P ((SCM arb)); -extern SCM scm_release_arbiter SCM_P ((SCM arb)); -extern void scm_init_arbiters SCM_P ((void)); - -#endif /* ARBITERSH */ diff --git a/libguile/async.c b/libguile/async.c deleted file mode 100644 index d2478fd65..000000000 --- a/libguile/async.c +++ /dev/null @@ -1,674 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include <signal.h> -#include "_scm.h" -#include "eval.h" -#include "throw.h" -#include "smob.h" - -#include "async.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - - -/* {Asynchronous Events} - * - * - * Async == thunk + mark. - * - * Setting the mark guarantees future execution of the thunk. More - * than one set may be satisfied by a single execution. - * - * scm_tick_clock decremented once per SCM_ALLOW_INTS. - * Async execution triggered by SCM_ALLOW_INTS when scm_tick_clock drops to 0. - * Async execution prevented by scm_mask_ints != 0. - * - * If the clock reaches 0 when scm_mask_ints != 0, then reset the clock - * to 1. - * - * If the clock reaches 0 any other time, run marked asyncs. - * - * From a unix signal handler, mark a corresponding async and set the clock - * to 1. Do SCM_REDEFER_INTS;/SCM_REALLOW_INTS so that if the signal handler is not - * called in the dynamic scope of a critical section, it is excecuted immediately. - * - * Overall, closely timed signals of a particular sort may be combined. Pending signals - * are delivered in a fixed priority order, regardless of arrival order. - * - */ - - - -unsigned int scm_async_clock = 20; -static unsigned int scm_async_rate = 20; -unsigned int scm_mask_ints = 1; - -static unsigned int scm_tick_clock = 0; -static unsigned int scm_tick_rate = 0; -static unsigned int scm_desired_tick_rate = 0; -static unsigned int scm_switch_clock = 0; -static unsigned int scm_switch_rate = 0; -static unsigned int scm_desired_switch_rate = 0; - -static SCM system_signal_asyncs[SCM_NUM_SIGS]; -static SCM handler_var; -static SCM symbol_signal; - - -struct scm_async -{ - int got_it; /* needs to be delivered? */ - SCM thunk; /* the handler. */ -}; - - -static long scm_tc16_async; - -#define SCM_ASYNCP(X) (scm_tc16_async == SCM_GCTYP16 (X)) -#define SCM_ASYNC(X) ((struct scm_async *)SCM_CDR (X)) - - - - - - -static int asyncs_pending SCM_P ((void)); - -static int -asyncs_pending () -{ - SCM pos; - pos = scm_asyncs; - while (pos != SCM_EOL) - { - SCM a; - struct scm_async * it; - a = SCM_CAR (pos); - it = SCM_ASYNC (a); - if (it->got_it) - return 1; - pos = SCM_CDR (pos); - } - return 0; -} - - - -void -scm_async_click () -{ - int owe_switch; - int owe_tick; - - if (!scm_switch_rate) - { - owe_switch = 0; - scm_switch_clock = scm_switch_rate = scm_desired_switch_rate; - scm_desired_switch_rate = 0; - } - else - { - owe_switch = (scm_async_rate >= scm_switch_clock); - if (owe_switch) - { - if (scm_desired_switch_rate) - { - scm_switch_clock = scm_switch_rate = scm_desired_switch_rate; - scm_desired_switch_rate = 0; - } - else - scm_switch_clock = scm_switch_rate; - } - else - { - if (scm_desired_switch_rate) - { - scm_switch_clock = scm_switch_rate = scm_desired_switch_rate; - scm_desired_switch_rate = 0; - } - else - scm_switch_clock -= scm_async_rate; - } - } - - if (scm_mask_ints) - { - if (owe_switch) - scm_switch (); - scm_async_clock = 1; - return;; - } - - if (!scm_tick_rate) - { - unsigned int r; - owe_tick = 0; - r = scm_desired_tick_rate; - if (r) - { - scm_desired_tick_rate = 0; - scm_tick_rate = r; - scm_tick_clock = r; - } - } - else - { - owe_tick = (scm_async_rate >= scm_tick_clock); - if (owe_tick) - { - scm_tick_clock = scm_tick_rate = scm_desired_tick_rate; - scm_desired_tick_rate = 0; - } - else - { - if (scm_desired_tick_rate) - { - scm_tick_clock = scm_tick_rate = scm_desired_tick_rate; - scm_desired_tick_rate = 0; - } - else - scm_tick_clock -= scm_async_rate; - } - } - - if (owe_tick) - scm_async_mark (system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)]); - - SCM_DEFER_INTS; - if (scm_tick_rate && scm_switch_rate) - { - scm_async_rate = min (scm_tick_clock, scm_switch_clock); - scm_async_clock = scm_async_rate; - } - else if (scm_tick_rate) - { - scm_async_clock = scm_async_rate = scm_tick_clock; - } - else if (scm_switch_rate) - { - scm_async_clock = scm_async_rate = scm_switch_clock; - } - else - scm_async_clock = scm_async_rate = 1 << 16; - SCM_ALLOW_INTS_ONLY; - - tail: - scm_run_asyncs (scm_asyncs); - - SCM_DEFER_INTS; - if (asyncs_pending ()) - { - SCM_ALLOW_INTS_ONLY; - goto tail; - } - SCM_ALLOW_INTS; - - if (owe_switch) - scm_switch (); -} - - - - - -void -scm_switch () -{ -#if 0 /* Thread switching code should probably reside here, but the - async switching code doesn't seem to work, so it's put in the - SCM_ASYNC_TICK macro instead. /mdj */ - SCM_THREAD_SWITCHING_CODE; -#endif -} - - - -static void scm_deliver_signal SCM_P ((int num)); - -static void -scm_deliver_signal (num) - int num; -{ - SCM handler; - handler = SCM_CDR (handler_var); - if (handler != SCM_BOOL_F) - scm_apply (handler, SCM_MAKINUM (num), scm_listofnull); - else - { - scm_mask_ints = 0; - scm_throw (symbol_signal, - scm_listify (SCM_MAKINUM (num), SCM_UNDEFINED)); - } -} - - - - - -static int print_async SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -print_async (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<async ", port); - scm_intprint(exp, 16, port); - scm_gen_putc('>', port); - return 1; -} - - -static SCM mark_async SCM_P ((SCM obj)); - -static SCM -mark_async (obj) - SCM obj; -{ - struct scm_async * it; - if (SCM_GC8MARKP (obj)) - return SCM_BOOL_F; - SCM_SETGC8MARK (obj); - it = SCM_ASYNC (obj); - return it->thunk; -} - - -static scm_sizet free_async SCM_P ((SCM obj)); - -static scm_sizet -free_async (obj) - SCM obj; -{ - struct scm_async * it; - it = SCM_ASYNC (obj); - scm_must_free ((char *)it); - return (sizeof (*it)); -} - - -static scm_smobfuns async_smob = -{ - mark_async, - free_async, - print_async, - 0 -}; - - - - -SCM_PROC(s_async, "async", 1, 0, 0, scm_async); - -SCM -scm_async (thunk) - SCM thunk; -{ - SCM it; - struct scm_async * async; - - SCM_NEWCELL (it); - SCM_DEFER_INTS; - SCM_SETCDR (it, SCM_EOL); - async = (struct scm_async *)scm_must_malloc (sizeof (*async), s_async); - async->got_it = 0; - async->thunk = thunk; - SCM_SETCDR (it, (SCM)async); - SCM_SETCAR (it, (SCM)scm_tc16_async); - SCM_ALLOW_INTS; - return it; -} - -SCM_PROC(s_system_async, "system-async", 1, 0, 0, scm_system_async); - -SCM -scm_system_async (thunk) - SCM thunk; -{ - SCM it; - SCM list; - - it = scm_async (thunk); - SCM_NEWCELL (list); - SCM_DEFER_INTS; - SCM_SETCAR (list, it); - SCM_SETCDR (list, scm_asyncs); - scm_asyncs = list; - SCM_ALLOW_INTS; - return it; -} - -SCM_PROC(s_async_mark, "async-mark", 1, 0, 0, scm_async_mark); - -SCM -scm_async_mark (a) - SCM a; -{ - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark); - it = SCM_ASYNC (a); - it->got_it = 1; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_system_async_mark, "system-async-mark", 1, 0, 0, scm_system_async_mark); - -SCM -scm_system_async_mark (a) - SCM a; -{ - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark); - it = SCM_ASYNC (a); - SCM_REDEFER_INTS; - it->got_it = 1; - scm_async_rate = 1 + scm_async_rate - scm_async_clock; - scm_async_clock = 1; - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_run_asyncs, "run-asyncs", 1, 0, 0, scm_run_asyncs); - -SCM -scm_run_asyncs (list_of_a) - SCM list_of_a; -{ - SCM pos; - - if (scm_mask_ints) - return SCM_BOOL_F; - pos = list_of_a; - while (pos != SCM_EOL) - { - SCM a; - struct scm_async * it; - SCM_ASSERT (SCM_NIMP (pos) && SCM_CONSP (pos), pos, SCM_ARG1, s_run_asyncs); - a = SCM_CAR (pos); - SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_run_asyncs); - it = SCM_ASYNC (a); - scm_mask_ints = 1; - if (it->got_it) - { - it->got_it = 0; - scm_apply (it->thunk, SCM_EOL, SCM_EOL); - } - scm_mask_ints = 0; - pos = SCM_CDR (pos); - } - return SCM_BOOL_T; -} - - - - -SCM_PROC(s_noop, "noop", 0, 0, 1, scm_noop); - -SCM -scm_noop (args) - SCM args; -{ - return (SCM_NULLP (args) - ? SCM_BOOL_F - : SCM_CAR (args)); -} - - - - -SCM_PROC(s_set_tick_rate, "set-tick-rate", 1, 0, 0, scm_set_tick_rate); - -SCM -scm_set_tick_rate (n) - SCM n; -{ - unsigned int old_n; - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_tick_rate); - old_n = scm_tick_rate; - scm_desired_tick_rate = SCM_INUM (n); - scm_async_rate = 1 + scm_async_rate - scm_async_clock; - scm_async_clock = 1; - return SCM_MAKINUM (old_n); -} - - - - -SCM_PROC(s_set_switch_rate, "set-switch-rate", 1, 0, 0, scm_set_switch_rate); - -SCM -scm_set_switch_rate (n) - SCM n; -{ - unsigned int old_n; - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_switch_rate); - old_n = scm_switch_rate; - scm_desired_switch_rate = SCM_INUM (n); - scm_async_rate = 1 + scm_async_rate - scm_async_clock; - scm_async_clock = 1; - return SCM_MAKINUM (old_n); -} - - - - -static SCM scm_sys_hup_async_thunk SCM_P ((void)); - -static SCM -scm_sys_hup_async_thunk () -{ - scm_deliver_signal (SCM_HUP_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_int_async_thunk SCM_P ((void)); - -static SCM -scm_sys_int_async_thunk () -{ - scm_deliver_signal (SCM_INT_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_fpe_async_thunk SCM_P ((void)); - -static SCM -scm_sys_fpe_async_thunk () -{ - scm_deliver_signal (SCM_FPE_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_bus_async_thunk SCM_P ((void)); - -static SCM -scm_sys_bus_async_thunk () -{ - scm_deliver_signal (SCM_BUS_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_segv_async_thunk SCM_P ((void)); - -static SCM -scm_sys_segv_async_thunk () -{ - scm_deliver_signal (SCM_SEGV_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_alrm_async_thunk SCM_P ((void)); - -static SCM -scm_sys_alrm_async_thunk () -{ - scm_deliver_signal (SCM_ALRM_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_gc_async_thunk SCM_P ((void)); - -static SCM -scm_sys_gc_async_thunk () -{ - scm_deliver_signal (SCM_GC_SIGNAL); - return SCM_BOOL_F; -} - - -static SCM scm_sys_tick_async_thunk SCM_P ((void)); - -static SCM -scm_sys_tick_async_thunk () -{ - scm_deliver_signal (SCM_TICK_SIGNAL); - return SCM_BOOL_F; -} - - - - - - -SCM -scm_take_signal (n) - int n; -{ - SCM ignored; - if (!scm_ints_disabled) - { - /* For reasons of speed, the SCM_NEWCELL macro doesn't defer - interrupts. Instead, it first sets its argument to point to - the first cell in the list, and then advances the freelist - pointer to the next cell. Now, if this procedure is - interrupted, the only anomalous state possible is to have - both SCM_NEWCELL's argument and scm_freelist pointing to the - same cell. To deal with this case, we always throw away the - first cell in scm_freelist here. - - At least, that's the theory. I'm not convinced that that's - the only anomalous path we need to worry about. */ - SCM_NEWCELL (ignored); - } - scm_system_async_mark (system_signal_asyncs[SCM_SIG_ORD(n)]); - return SCM_BOOL_F; -} - - - -SCM_PROC(s_unmask_signals, "unmask-signals", 0, 0, 0, scm_unmask_signals); - -SCM -scm_unmask_signals () -{ - scm_mask_ints = 0; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_mask_signals, "mask-signals", 0, 0, 0, scm_mask_signals); - -SCM -scm_mask_signals () -{ - scm_mask_ints = 1; - return SCM_UNSPECIFIED; -} - - - - -void -scm_init_async () -{ - SCM a_thunk; - scm_tc16_async = scm_newsmob (&async_smob); - symbol_signal = SCM_CAR (scm_sysintern ("signal", SCM_UNDEFINED)); - scm_permanent_object (symbol_signal); - - /* These are in the opposite order of delivery priortity. - * - * Error conditions are given low priority: - */ - a_thunk = scm_make_gsubr ("%hup-thunk", 0, 0, 0, scm_sys_hup_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_HUP_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%int-thunk", 0, 0, 0, scm_sys_int_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_INT_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%fpe-thunk", 0, 0, 0, scm_sys_fpe_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_FPE_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%bus-thunk", 0, 0, 0, scm_sys_bus_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_BUS_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%segv-thunk", 0, 0, 0, scm_sys_segv_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_SEGV_SIGNAL)] = scm_system_async (a_thunk); - - - a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_GC_SIGNAL)] = scm_system_async (a_thunk); - - /* Clock and PC driven conditions are given highest priority. */ - a_thunk = scm_make_gsubr ("%tick-thunk", 0, 0, 0, scm_sys_tick_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)] = scm_system_async (a_thunk); - a_thunk = scm_make_gsubr ("%alrm-thunk", 0, 0, 0, scm_sys_alrm_async_thunk); - system_signal_asyncs[SCM_SIG_ORD(SCM_ALRM_SIGNAL)] = scm_system_async (a_thunk); - - handler_var = scm_sysintern ("signal-handler", SCM_UNDEFINED); - SCM_SETCDR (handler_var, SCM_BOOL_F); - scm_permanent_object (handler_var); -#include "async.x" -} diff --git a/libguile/async.h b/libguile/async.h deleted file mode 100644 index 217603ba6..000000000 --- a/libguile/async.h +++ /dev/null @@ -1,71 +0,0 @@ -/* classes: h_files */ - -#ifndef ASYNCH -#define ASYNCH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - -extern unsigned int scm_mask_ints; - - - -extern void scm_async_click SCM_P ((void)); -extern void scm_switch SCM_P ((void)); -extern SCM scm_async SCM_P ((SCM thunk)); -extern SCM scm_system_async SCM_P ((SCM thunk)); -extern SCM scm_async_mark SCM_P ((SCM a)); -extern SCM scm_system_async_mark SCM_P ((SCM a)); -extern SCM scm_run_asyncs SCM_P ((SCM list_of_a)); -extern SCM scm_noop SCM_P ((SCM args)); -extern SCM scm_set_tick_rate SCM_P ((SCM n)); -extern SCM scm_set_switch_rate SCM_P ((SCM n)); -extern SCM scm_take_signal SCM_P ((int n)); -extern SCM scm_unmask_signals SCM_P ((void)); -extern SCM scm_mask_signals SCM_P ((void)); -extern void scm_init_async SCM_P ((void)); - -#endif /* ASYNCH */ diff --git a/libguile/backtrace.c b/libguile/backtrace.c deleted file mode 100644 index 365b6ca58..000000000 --- a/libguile/backtrace.c +++ /dev/null @@ -1,436 +0,0 @@ -/* Printing of backtraces and error messages - * Copyright (C) 1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - -#include <stdio.h> -#include "_scm.h" -#include "stacks.h" -#include "srcprop.h" -#include "genio.h" -#include "struct.h" -#include "strports.h" - -#include "backtrace.h" - -/* {Error reporting and backtraces} - * (A first approximation.) - * - * Note that these functions shouldn't generate errors themselves. - */ - -#ifndef SCM_RECKLESS -#undef SCM_ASSERT -#define SCM_ASSERT(_cond, _arg, _pos, _subr) \ - if (!(_cond)) \ - return SCM_BOOL_F; -#endif - -static void display_header SCM_P ((SCM source, SCM port)); -static void -display_header (source, port) - SCM source; - SCM port; -{ - SCM fname = (SCM_NIMP (source) && SCM_MEMOIZEDP (source) - ? scm_source_property (source, scm_i_filename) - : SCM_BOOL_F); - if (SCM_NIMP (fname) && SCM_STRINGP (fname)) - { - scm_prin1 (fname, port, 0); - scm_gen_putc (':', port); - scm_prin1 (scm_source_property (source, scm_i_line), port, 0); - scm_gen_putc (':', port); - scm_prin1 (scm_source_property (source, scm_i_column), port, 0); - } - else - scm_gen_puts (scm_regular_string, "ERROR", port); - scm_gen_puts (scm_regular_string, ": ", port); -} - - -void -scm_display_error_message (message, args, port) - SCM message; - SCM args; - SCM port; -{ - int writingp; - char *start; - char *p; - - if (!SCM_STRINGP (message) || SCM_IMP (args) || !scm_list_p (args)) - { - scm_prin1 (message, port, 0); - scm_gen_putc ('\n', port); - return; - } - - start = SCM_CHARS (message); - for (p = start; *p != '\0'; ++p) - if (*p == '%') - { - if (SCM_IMP (args) || SCM_NCONSP (args)) - continue; - - ++p; - if (*p == 's') - writingp = 0; - else if (*p == 'S') - writingp = 1; - else - continue; - - scm_gen_write (scm_regular_string, start, p - start - 1, port); - scm_prin1 (SCM_CAR (args), port, writingp); - args = SCM_CDR (args); - start = p + 1; - } - scm_gen_write (scm_regular_string, start, p - start, port); - scm_gen_putc ('\n', port); -} - -static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port)); -static void -display_expression (frame, pname, source, port) - SCM frame; - SCM pname; - SCM source; - SCM port; -{ - SCM print_state = scm_make_print_state (); - scm_print_state *pstate = SCM_PRINT_STATE (print_state); - pstate->writingp = 0; - pstate->fancyp = 1; - pstate->level = 2; - pstate->length = 3; - if (SCM_NIMP (pname) && SCM_ROSTRINGP (pname)) - { - if (SCM_NIMP (frame) - && SCM_FRAMEP (frame) - && SCM_FRAME_EVAL_ARGS_P (frame)) - scm_gen_puts (scm_regular_string, "While evaluating arguments to ", port); - else - scm_gen_puts (scm_regular_string, "In procedure ", port); - scm_iprin1 (pname, port, pstate); - if (SCM_NIMP (source) && SCM_MEMOIZEDP (source)) - { - scm_gen_puts (scm_regular_string, " in expression ", port); - pstate->writingp = 1; - scm_iprin1 (scm_unmemoize (source), port, pstate); - } - } - else if (SCM_NIMP (source)) - { - scm_gen_puts (scm_regular_string, "In expression ", port); - pstate->writingp = 1; - scm_iprin1 (scm_unmemoize (source), port, pstate); - } - scm_gen_puts (scm_regular_string, ":\n", port); - scm_free_print_state (print_state); -} - -SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error); -SCM -scm_display_error (stack, port, subr, message, args, rest) - SCM stack; - SCM port; - SCM subr; - SCM message; - SCM args; - SCM rest; -{ - SCM current_frame = SCM_BOOL_F; - SCM source = SCM_BOOL_F; - SCM pname = SCM_BOOL_F; - if (SCM_DEBUGGINGP - && SCM_NIMP (stack) - && SCM_STACKP (stack) - && SCM_STACK_LENGTH (stack) > 0) - { - current_frame = scm_stack_ref (stack, SCM_INUM0); - source = SCM_FRAME_SOURCE (current_frame); - if (!(SCM_NIMP (source) && SCM_MEMOIZEDP (source))) - source = SCM_FRAME_SOURCE (SCM_FRAME_PREV (current_frame)); - if (SCM_FRAME_PROC_P (current_frame) - && scm_procedure_p (SCM_FRAME_PROC (current_frame)) == SCM_BOOL_T) - pname = scm_procedure_name (SCM_FRAME_PROC (current_frame)); - } - if (!(SCM_NIMP (pname) && SCM_ROSTRINGP (pname))) - pname = subr; - if ((SCM_NIMP (source) && SCM_MEMOIZEDP (source)) - || (SCM_NIMP (pname) && SCM_ROSTRINGP (pname))) - { - display_header (source, port); - display_expression (current_frame, pname, source, port); - } - display_header (source, port); - scm_display_error_message (message, args, port); - return SCM_UNSPECIFIED; -} - -static void indent SCM_P ((int n, SCM port)); -static void -indent (n, port) - int n; - SCM port; -{ - int i; - for (i = 0; i < n; ++i) - scm_gen_putc (' ', port); -} - -static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate)); -static void -display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate) - char *hdr; - SCM exp; - char *tlr; - int indentation; - SCM sport; - SCM port; - scm_print_state *pstate; -{ - pstate->level = 2; - pstate->length = 3; - if (SCM_NIMP (exp) && SCM_CONSP (exp)) - { - scm_iprlist (hdr, exp, tlr[0], port, pstate); - scm_gen_puts (scm_regular_string, &tlr[1], port); - } - else - scm_iprin1 (exp, port, pstate); - scm_gen_putc ('\n', port); -} - -static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate)); -static void -display_frame (frame, nfield, indentation, sport, port, pstate) - SCM frame; - int nfield; - int indentation; - SCM sport; - SCM port; - scm_print_state *pstate; -{ - int n, i, j; - - /* Announce missing frames? */ - if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame)) - { - indent (nfield + 1 + indentation, port); - scm_gen_puts (scm_regular_string, "...\n", port); - } - - /* Check size of frame number. */ - n = SCM_FRAME_NUMBER (frame); - for (i = 0, j = n; j > 0; ++i) j /= 10; - - /* Number indentation. */ - indent (nfield - (i ? i : 1), port); - - /* Frame number. */ - scm_iprin1 (SCM_MAKINUM (n), port, pstate); - - /* Real frame marker */ - scm_gen_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port); - - /* Indentation. */ - indent (indentation, port); - - if (SCM_FRAME_PROC_P (frame)) - /* Display an application. */ - { - SCM proc = SCM_FRAME_PROC (frame); - SCM name = (SCM_NFALSEP (scm_procedure_p (proc)) - ? scm_procedure_name (proc) - : SCM_BOOL_F); - display_frame_expr ("[", - scm_cons (SCM_NFALSEP (name) ? name : proc, - SCM_FRAME_ARGS (frame)), - SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]", - nfield + 1 + indentation, - sport, - port, - pstate); - } - else - /* Display a special form. */ - { - SCM source = SCM_FRAME_SOURCE (frame); - SCM copy = scm_source_property (source, scm_i_copy); - display_frame_expr ("(", - SCM_NIMP (copy) && SCM_CONSP (copy) - ? copy - : scm_unmemoize (source), - ")", - nfield + 1 + indentation, - sport, - port, - pstate); - } - - /* Announce missing frames? */ - if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame)) - { - indent (nfield + 1 + indentation, port); - scm_gen_puts (scm_regular_string, "...\n", port); - } -} - -SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace); -SCM -scm_display_backtrace (stack, port, first, depth) - SCM stack; - SCM port; - SCM first; - SCM depth; -{ - int n_frames, beg, end, n, i, j; - int nfield, indent_p, indentation; - SCM frame, sport, print_state; - scm_print_state *pstate; - - /* Argument checking and extraction. */ - SCM_ASSERT (SCM_NIMP (stack) && SCM_STACKP (stack), - stack, - SCM_ARG1, - s_display_backtrace); - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), - port, - SCM_ARG2, - s_display_backtrace); - n_frames = SCM_INUM (scm_stack_length (stack)); - n = SCM_INUMP (depth) ? SCM_INUM (depth) : SCM_BACKTRACE_DEPTH; - if (SCM_BACKWARDS_P) - { - beg = SCM_INUMP (first) ? SCM_INUM (first) : 0; - end = beg + n - 1; - if (end >= n_frames) - end = n_frames - 1; - n = end - beg + 1; - } - else - { - if (SCM_INUMP (first)) - { - beg = SCM_INUM (first); - end = beg - n + 1; - if (end < 0) - end = 0; - } - else - { - beg = n - 1; - end = 0; - if (beg >= n_frames) - beg = n_frames - 1; - } - n = beg - end + 1; - } - SCM_ASSERT (beg >= 0 && beg < n_frames, first, SCM_ARG3, s_display_backtrace); - SCM_ASSERT (n > 0, depth, SCM_ARG4, s_display_backtrace); - - /* Create a string port used for adaptation of printing parameters. */ - sport = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED), - SCM_OPN | SCM_WRTNG, - s_display_backtrace); - - /* Create a print state for printing of frames. */ - print_state = scm_make_print_state (); - pstate = SCM_PRINT_STATE (print_state); - pstate->writingp = 1; - pstate->fancyp = 1; - - /* First find out if it's reasonable to do indentation. */ - if (SCM_BACKWARDS_P) - indent_p = 0; - else - { - indent_p = 1; - frame = scm_stack_ref (stack, SCM_MAKINUM (beg)); - for (i = 0, j = 0; i < n; ++i) - { - if (SCM_FRAME_REAL_P (frame)) - ++j; - if (j > SCM_BACKTRACE_INDENT) - { - indent_p = 0; - break; - } - frame = (SCM_BACKWARDS_P - ? SCM_FRAME_PREV (frame) - : SCM_FRAME_NEXT (frame)); - } - } - - /* Determine size of frame number field. */ - j = SCM_FRAME_NUMBER (scm_stack_ref (stack, SCM_MAKINUM (end))); - for (i = 0; j > 0; ++i) j /= 10; - nfield = i ? i : 1; - - scm_gen_puts (scm_regular_string, "Backtrace:\n", port); - - /* Print frames. */ - frame = scm_stack_ref (stack, SCM_MAKINUM (beg)); - indentation = 1; - display_frame (frame, nfield, indentation, sport, port, pstate); - for (i = 1; i < n; ++i) - { - if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame)) - ++indentation; - frame = SCM_BACKWARDS_P ? SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame); - display_frame (frame, nfield, indentation, sport, port, pstate); - } - - return SCM_UNSPECIFIED; -} - - - -void -scm_init_backtrace () -{ -#include "backtrace.x" -} diff --git a/libguile/backtrace.h b/libguile/backtrace.h deleted file mode 100644 index 830a1eb2a..000000000 --- a/libguile/backtrace.h +++ /dev/null @@ -1,58 +0,0 @@ -/* classes: h_files */ - -#ifndef BACKTRACEH -#define BACKTRACEH -/* Copyright (C) 1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include "libguile/__scm.h" - -void scm_display_error_message SCM_P ((SCM message, SCM args, SCM port)); -SCM scm_display_error SCM_P ((SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest)); -SCM scm_display_backtrace SCM_P ((SCM stack, SCM port, SCM first, SCM depth)); - -void scm_init_backtrace SCM_P ((void)); - -#endif /* BACKTRACEH */ diff --git a/libguile/boolean.c b/libguile/boolean.c deleted file mode 100644 index 3267f28eb..000000000 --- a/libguile/boolean.c +++ /dev/null @@ -1,78 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "boolean.h" - - - -SCM_PROC(s_not, "not", 1, 0, 0, scm_not); - -SCM -scm_not(x) - SCM x; -{ - return SCM_FALSEP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC(s_boolean_p, "boolean?", 1, 0, 0, scm_boolean_p); - -SCM -scm_boolean_p(obj) - SCM obj; -{ - if (SCM_BOOL_F==obj) return SCM_BOOL_T; - if (SCM_BOOL_T==obj) return SCM_BOOL_T; - return SCM_BOOL_F; -} - - - -void -scm_init_boolean () -{ -#include "boolean.x" -} - diff --git a/libguile/boolean.h b/libguile/boolean.h deleted file mode 100644 index c9945e566..000000000 --- a/libguile/boolean.h +++ /dev/null @@ -1,67 +0,0 @@ -/* classes: h_files */ - -#ifndef BOOLEANH -#define BOOLEANH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -/* Boolean Values - * - */ -#define SCM_FALSEP(x) (SCM_BOOL_F == (x)) -#define SCM_NFALSEP(x) (SCM_BOOL_F != (x)) - -/* SCM_BOOL_NOT returns the other boolean. - * The order of ^s here is important for Borland C++ (!?!?!) - */ -#define SCM_BOOL_NOT(x) ((x) ^ (SCM_BOOL_T ^ SCM_BOOL_F)) - - - -extern SCM scm_not SCM_P ((SCM x)); -extern SCM scm_boolean_p SCM_P ((SCM obj)); -extern void scm_init_boolean SCM_P ((void)); - -#endif /* BOOLEANH */ diff --git a/libguile/chars.c b/libguile/chars.c deleted file mode 100644 index cc77d3d09..000000000 --- a/libguile/chars.c +++ /dev/null @@ -1,408 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include <ctype.h> -#include "_scm.h" - -#include "chars.h" - - - - -SCM_PROC(s_char_p, "char?", 1, 0, 0, scm_char_p); - -SCM -scm_char_p(x) - SCM x; -{ - return SCM_ICHRP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_eq_p, "char=?", scm_tc7_rpsubr, scm_char_eq_p); - -SCM -scm_char_eq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_eq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_eq_p); - return (SCM_ICHR(x) == SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC1 (s_char_less_p, "char<?", scm_tc7_rpsubr, scm_char_less_p); - -SCM -scm_char_less_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_less_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_less_p); - return (SCM_ICHR(x) < SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_leq_p, "char<=?", scm_tc7_rpsubr, scm_char_leq_p); - -SCM -scm_char_leq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_leq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_leq_p); - return (SCM_ICHR(x) <= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_gr_p, "char>?", scm_tc7_rpsubr, scm_char_gr_p); - -SCM -scm_char_gr_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_gr_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_gr_p); - return (SCM_ICHR(x) > SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_geq_p, "char>=?", scm_tc7_rpsubr, scm_char_geq_p); - -SCM -scm_char_geq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_geq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_geq_p); - return (SCM_ICHR(x) >= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, scm_char_ci_eq_p); - -SCM -scm_char_ci_eq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_eq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_eq_p); - return (scm_upcase(SCM_ICHR(x))==scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr, scm_char_ci_less_p); - -SCM -scm_char_ci_less_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_less_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_less_p); - return (scm_upcase(SCM_ICHR(x)) < scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr, scm_char_ci_leq_p); - -SCM -scm_char_ci_leq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_leq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_leq_p); - return (scm_upcase(SCM_ICHR(x)) <= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, scm_char_ci_gr_p); - -SCM -scm_char_ci_gr_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_gr_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_gr_p); - return (scm_upcase(SCM_ICHR(x)) > scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, scm_char_ci_geq_p); - -SCM -scm_char_ci_geq_p(x, y) - SCM x; - SCM y; -{ - SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_geq_p); - SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_geq_p); - return (scm_upcase(SCM_ICHR(x)) >= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC(s_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, scm_char_alphabetic_p); - -SCM -scm_char_alphabetic_p(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_alphabetic_p); - return (isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_char_numeric_p, "char-numeric?", 1, 0, 0, scm_char_numeric_p); - -SCM -scm_char_numeric_p(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_numeric_p); - return (isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_char_whitespace_p, "char-whitespace?", 1, 0, 0, scm_char_whitespace_p); - -SCM -scm_char_whitespace_p(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_whitespace_p); - return (isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; -} - - - -SCM_PROC(s_char_upper_case_p, "char-upper-case?", 1, 0, 0, scm_char_upper_case_p); - -SCM -scm_char_upper_case_p(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p); - return (isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC(s_char_lower_case_p, "char-lower-case?", 1, 0, 0, scm_char_lower_case_p); - -SCM -scm_char_lower_case_p(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_lower_case_p); - return (isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F; -} - - - -SCM_PROC (s_char_is_both_p, "char-is-both?", 1, 0, 0, scm_char_is_both_p); - -SCM -scm_char_is_both_p (chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p); - return ((isascii(SCM_ICHR(chr)) && (isupper(SCM_ICHR(chr)) || islower(SCM_ICHR(chr)))) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - - -SCM_PROC(s_char_to_integer, "char->integer", 1, 0, 0, scm_char_to_integer); - -SCM -scm_char_to_integer(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_to_integer); - return scm_ulong2num((unsigned long)SCM_ICHR(chr)); -} - - - -SCM_PROC(s_integer_to_char, "integer->char", 1, 0, 0, scm_integer_to_char); - -SCM -scm_integer_to_char(n) - SCM n; -{ - unsigned long ni; - - ni = 0xffff & scm_num2ulong (n, (char *)SCM_ARG1, s_integer_to_char); - return SCM_MAKICHR(SCM_INUM(n)); -} - - -SCM_PROC(s_char_upcase, "char-upcase", 1, 0, 0, scm_char_upcase); - -SCM -scm_char_upcase(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upcase); - return SCM_MAKICHR(scm_upcase(SCM_ICHR(chr))); -} - - -SCM_PROC(s_char_downcase, "char-downcase", 1, 0, 0, scm_char_downcase); - -SCM -scm_char_downcase(chr) - SCM chr; -{ - SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_downcase); - return SCM_MAKICHR(scm_downcase(SCM_ICHR(chr))); -} - - - - - -static unsigned char scm_upcase_table[SCM_CHAR_CODE_LIMIT]; -static unsigned char scm_downcase_table[SCM_CHAR_CODE_LIMIT]; -static unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz"; -static unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; - - -void -scm_tables_prehistory () -{ - int i; - for (i = 0; i < SCM_CHAR_CODE_LIMIT; i++) - scm_upcase_table[i] = scm_downcase_table[i] = i; - for (i = 0; i < sizeof scm_lowers / sizeof (char); i++) - { - scm_upcase_table[scm_lowers[i]] = scm_uppers[i]; - scm_downcase_table[scm_uppers[i]] = scm_lowers[i]; - } -} - - -int -scm_upcase (c) - unsigned int c; -{ - if (c < sizeof (scm_upcase_table)) - return scm_upcase_table[c]; - else - return c; -} - - -int -scm_downcase (c) - unsigned int c; -{ - if (c < sizeof (scm_downcase_table)) - return scm_downcase_table[c]; - else - return c; -} - - -#ifdef _DCC -# define ASCII -#else -# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) -# define EBCDIC -# endif /* (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */ -# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) -# define ASCII -# endif /* (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */ -#endif /* def _DCC */ - - -#ifdef EBCDIC -char *scm_charnames[] = -{ - "nul","soh","stx","etx", "pf", "ht", "lc","del", - 0 , 0 ,"smm", "vt", "ff", "cr", "so", "si", - "dle","dc1","dc2","dc3","res", "nl", "bs", "il", - "can", "em", "cc", 0 ,"ifs","igs","irs","ius", - "ds","sos", "fs", 0 ,"byp", "lf","eob","pre", - 0 , 0 , "sm", 0 , 0 ,"enq","ack","bel", - 0 , 0 ,"syn", 0 , "pn", "rs", "uc","eot", - 0 , 0 , 0 , 0 ,"dc4","nak", 0 ,"sub", - "space", scm_s_newline, "tab", "backspace", "return", "page", "null"}; - -char scm_charnums[] = -"\000\001\002\003\004\005\006\007\ -\010\011\012\013\014\015\016\017\ -\020\021\022\023\024\025\026\027\ -\030\031\032\033\034\035\036\037\ -\040\041\042\043\044\045\046\047\ -\050\051\052\053\054\055\056\057\ -\060\061\062\063\064\065\066\067\ -\070\071\072\073\074\075\076\077\ - \n\t\b\r\f\0"; -#endif /* def EBCDIC */ -#ifdef ASCII -char *scm_charnames[] = -{ - "nul","soh","stx","etx","eot","enq","ack","bel", - "bs", "ht", "nl", "vt", "np", "cr", "so", "si", - "dle","dc1","dc2","dc3","dc4","nak","syn","etb", - "can", "em","sub","esc", "fs", "gs", "rs", "us", - "space", "newline", "tab", "backspace", "return", "page", "null", "del"}; -char scm_charnums[] = -"\000\001\002\003\004\005\006\007\ -\010\011\012\013\014\015\016\017\ -\020\021\022\023\024\025\026\027\ -\030\031\032\033\034\035\036\037\ - \n\t\b\r\f\0\177"; -#endif /* def ASCII */ - -int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *); - - - - - -void -scm_init_chars () -{ -#include "chars.x" -} - diff --git a/libguile/chars.h b/libguile/chars.h deleted file mode 100644 index 8ad7672d3..000000000 --- a/libguile/chars.h +++ /dev/null @@ -1,90 +0,0 @@ -/* classes: h_files */ - -#ifndef SCM_CHARSH -#define SCM_CHARSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -/* Immediate Characters - */ -#define SCM_ICHRP(x) (SCM_ITAG8(x) == scm_tc8_char) -#define SCM_ICHR(x) ((unsigned int)SCM_ITAG8_DATA(x)) -#define SCM_MAKICHR(x) SCM_MAKE_ITAG8(x, scm_tc8_char) - - - -extern char *scm_charnames[]; -extern int scm_n_charnames; -extern char scm_charnums[]; - - - -extern SCM scm_char_p SCM_P ((SCM x)); -extern SCM scm_char_eq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_less_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_leq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_gr_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_geq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_ci_eq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_ci_less_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_ci_leq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_ci_gr_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_ci_geq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_char_alphabetic_p SCM_P ((SCM chr)); -extern SCM scm_char_numeric_p SCM_P ((SCM chr)); -extern SCM scm_char_whitespace_p SCM_P ((SCM chr)); -extern SCM scm_char_upper_case_p SCM_P ((SCM chr)); -extern SCM scm_char_lower_case_p SCM_P ((SCM chr)); -extern SCM scm_char_is_both_p SCM_P ((SCM chr)); -extern SCM scm_char_to_integer SCM_P ((SCM chr)); -extern SCM scm_integer_to_char SCM_P ((SCM n)); -extern SCM scm_char_upcase SCM_P ((SCM chr)); -extern SCM scm_char_downcase SCM_P ((SCM chr)); -extern void scm_tables_prehistory SCM_P ((void)); -extern int scm_upcase SCM_P ((unsigned int c)); -extern int scm_downcase SCM_P ((unsigned int c)); -extern void scm_init_chars SCM_P ((void)); - -#endif /* SCM_CHARSH */ diff --git a/libguile/configure b/libguile/configure deleted file mode 100755 index e156c59b0..000000000 --- a/libguile/configure +++ /dev/null @@ -1,3057 +0,0 @@ -#! /bin/sh - -# Guess values for system-dependent variables and create Makefiles. -# Generated automatically using autoconf version 2.12 -# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - -# Defaults: -ac_help= -ac_default_prefix=/usr/local -# Any additions from configure.in: -ac_help="$ac_help - --disable-debug Don't include debugging support" -ac_help="$ac_help - --enable-dynamic-linking Include support for dynamic linking" -ac_help="$ac_help - --with-threads thread interface" - -# Initialize some variables set by options. -# The variables have the same names as the options, with -# dashes changed to underlines. -build=NONE -cache_file=./config.cache -exec_prefix=NONE -host=NONE -no_create= -nonopt=NONE -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -target=NONE -verbose= -x_includes=NONE -x_libraries=NONE -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datadir='${prefix}/share' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -libdir='${exec_prefix}/lib' -includedir='${prefix}/include' -oldincludedir='/usr/include' -infodir='${prefix}/info' -mandir='${prefix}/man' - -# Initialize some other variables. -subdirs= -MFLAGS= MAKEFLAGS= -# Maximum number of lines to put in a shell here document. -ac_max_here_lines=12 - -ac_prev= -for ac_option -do - - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval "$ac_prev=\$ac_option" - ac_prev= - continue - fi - - case "$ac_option" in - -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; - *) ac_optarg= ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case "$ac_option" in - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir="$ac_optarg" ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build="$ac_optarg" ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file="$ac_optarg" ;; - - -datadir | --datadir | --datadi | --datad | --data | --dat | --da) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ - | --da=*) - datadir="$ac_optarg" ;; - - -disable-* | --disable-*) - ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - eval "enable_${ac_feature}=no" ;; - - -enable-* | --enable-*) - ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "enable_${ac_feature}='$ac_optarg'" ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix="$ac_optarg" ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he) - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat << EOF -Usage: configure [options] [host] -Options: [defaults in brackets after descriptions] -Configuration: - --cache-file=FILE cache test results in FILE - --help print this message - --no-create do not create output files - --quiet, --silent do not print \`checking...' messages - --version print the version of autoconf that created configure -Directory and file names: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [same as prefix] - --bindir=DIR user executables in DIR [EPREFIX/bin] - --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] - --libexecdir=DIR program executables in DIR [EPREFIX/libexec] - --datadir=DIR read-only architecture-independent data in DIR - [PREFIX/share] - --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data in DIR - [PREFIX/com] - --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] - --libdir=DIR object code libraries in DIR [EPREFIX/lib] - --includedir=DIR C header files in DIR [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] - --infodir=DIR info documentation in DIR [PREFIX/info] - --mandir=DIR man documentation in DIR [PREFIX/man] - --srcdir=DIR find the sources in DIR [configure dir or ..] - --program-prefix=PREFIX prepend PREFIX to installed program names - --program-suffix=SUFFIX append SUFFIX to installed program names - --program-transform-name=PROGRAM - run sed PROGRAM on installed program names -EOF - cat << EOF -Host type: - --build=BUILD configure for building on BUILD [BUILD=HOST] - --host=HOST configure for HOST [guessed] - --target=TARGET configure for TARGET [TARGET=HOST] -Features and packages: - --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) - --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --x-includes=DIR X include files are in DIR - --x-libraries=DIR X library files are in DIR -EOF - if test -n "$ac_help"; then - echo "--enable and --with options recognized:$ac_help" - fi - exit 0 ;; - - -host | --host | --hos | --ho) - ac_prev=host ;; - -host=* | --host=* | --hos=* | --ho=*) - host="$ac_optarg" ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir="$ac_optarg" ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir="$ac_optarg" ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir="$ac_optarg" ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir="$ac_optarg" ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst \ - | --locals | --local | --loca | --loc | --lo) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* \ - | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) - localstatedir="$ac_optarg" ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir="$ac_optarg" ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir="$ac_optarg" ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix="$ac_optarg" ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix="$ac_optarg" ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix="$ac_optarg" ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name="$ac_optarg" ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir="$ac_optarg" ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir="$ac_optarg" ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site="$ac_optarg" ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir="$ac_optarg" ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir="$ac_optarg" ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target="$ac_optarg" ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers) - echo "configure generated by autoconf version 2.12" - exit 0 ;; - - -with-* | --with-*) - ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "with_${ac_package}='$ac_optarg'" ;; - - -without-* | --without-*) - ac_package=`echo $ac_option|sed -e 's/-*without-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - eval "with_${ac_package}=no" ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes="$ac_optarg" ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries="$ac_optarg" ;; - - -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } - ;; - - *) - if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then - echo "configure: warning: $ac_option: invalid host type" 1>&2 - fi - if test "x$nonopt" != xNONE; then - { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } - fi - nonopt="$ac_option" - ;; - - esac -done - -if test -n "$ac_prev"; then - { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } -fi - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -# File descriptor usage: -# 0 standard input -# 1 file creation -# 2 errors and warnings -# 3 some systems may open it to /dev/tty -# 4 used on the Kubota Titan -# 6 checking for... messages and results -# 5 compiler messages saved in config.log -if test "$silent" = yes; then - exec 6>/dev/null -else - exec 6>&1 -fi -exec 5>./config.log - -echo "\ -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. -" 1>&5 - -# Strip out --no-create and --no-recursion so they do not pile up. -# Also quote any args containing shell metacharacters. -ac_configure_args= -for ac_arg -do - case "$ac_arg" in - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) ;; - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; - *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) - ac_configure_args="$ac_configure_args '$ac_arg'" ;; - *) ac_configure_args="$ac_configure_args $ac_arg" ;; - esac -done - -# NLS nuisances. -# Only set these to C if already set. These must not be set unconditionally -# because not all systems understand e.g. LANG=C (notably SCO). -# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! -# Non-C LC_CTYPE values break the ctype check. -if test "${LANG+set}" = set; then LANG=C; export LANG; fi -if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi -if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi -if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -rf conftest* confdefs.h -# AIX cpp loses on an empty file, so make sure it contains at least a newline. -echo > confdefs.h - -# A filename unique to this package, relative to the directory that -# configure is in, which we can look for to find out if srcdir is correct. -ac_unique_file=eval.c - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then its parent. - ac_prog=$0 - ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` - test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. - srcdir=$ac_confdir - if test ! -r $srcdir/$ac_unique_file; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r $srcdir/$ac_unique_file; then - if test "$ac_srcdir_defaulted" = yes; then - { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } - else - { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } - fi -fi -srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` - -# Prefer explicitly selected file to automatically selected ones. -if test -z "$CONFIG_SITE"; then - if test "x$prefix" != xNONE; then - CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" - else - CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" - fi -fi -for ac_site_file in $CONFIG_SITE; do - if test -r "$ac_site_file"; then - echo "loading site script $ac_site_file" - . "$ac_site_file" - fi -done - -if test -r "$cache_file"; then - echo "loading cache $cache_file" - . $cache_file -else - echo "creating cache $cache_file" - > $cache_file -fi - -ac_ext=c -# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. -ac_cpp='$CPP $CPPFLAGS' -ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' -ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' -cross_compiling=$ac_cv_prog_cc_cross - -if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then - # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. - if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then - ac_n= ac_c=' -' ac_t=' ' - else - ac_n=-n ac_c= ac_t= - fi -else - ac_n= ac_c='\c' ac_t= -fi - - - - - -ac_aux_dir= -for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do - if test -f $ac_dir/install-sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f $ac_dir/install.sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - fi -done -if test -z "$ac_aux_dir"; then - { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } -fi -ac_config_guess=$ac_aux_dir/config.guess -ac_config_sub=$ac_aux_dir/config.sub -ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. - -# Find a good install program. We prefer a C program (faster), -# so one script is as good as another. But avoid the broken or -# incompatible versions: -# SysV /etc/install, /usr/sbin/install -# SunOS /usr/etc/install -# IRIX /sbin/install -# AIX /bin/install -# AFS /usr/afsws/bin/install, which mishandles nonexistent args -# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" -# ./install, which can be erroneously created by make from ./install.sh. -echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:561: checking for a BSD compatible install" >&5 -if test -z "$INSTALL"; then -if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - # Account for people who put trailing slashes in PATH elements. - case "$ac_dir/" in - /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; - *) - # OSF1 and SCO ODT 3.0 have their own names for install. - for ac_prog in ginstall installbsd scoinst install; do - if test -f $ac_dir/$ac_prog; then - if test $ac_prog = install && - grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then - # AIX install. It has an incompatible calling convention. - # OSF/1 installbsd also uses dspmsg, but is usable. - : - else - ac_cv_path_install="$ac_dir/$ac_prog -c" - break 2 - fi - fi - done - ;; - esac - done - IFS="$ac_save_IFS" - -fi - if test "${ac_cv_path_install+set}" = set; then - INSTALL="$ac_cv_path_install" - else - # As a last resort, use the slow shell script. We don't cache a - # path for INSTALL within a source directory, because that will - # break other packages using the cache if that directory is - # removed, or if the path is relative. - INSTALL="$ac_install_sh" - fi -fi -echo "$ac_t""$INSTALL" 1>&6 - -# Use test -z because SunOS4 sh mishandles braces in ${var-val}. -# It thinks the first close brace ends the variable substitution. -test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' - -test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' - - -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' - - -. $srcdir/../GUILE-VERSION - -PACKAGE=$PACKAGE - -cat >> confdefs.h <<EOF -#define PACKAGE "$PACKAGE" -EOF - -VERSION=$VERSION - -cat >> confdefs.h <<EOF -#define VERSION "$VERSION" -EOF - -echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6 -echo "configure:629: checking whether build environment is sane" >&5 -echo timestamp > conftestfile -# Do this in a subshell so we don't clobber the current shell's -# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? -if (set X `ls -t $srcdir/configure conftestfile`; test "$2" = conftestfile) -then - # Ok. - : -else - { echo "configure: error: newly created file is older than distributed files! -Check your system clock" 1>&2; exit 1; } -fi -rm -f conftest* -echo "$ac_t""yes" 1>&6 -if test "$program_transform_name" = s,x,x,; then - program_transform_name= -else - # Double any \ or $. echo might interpret backslashes. - cat <<\EOF_SED > conftestsed -s,\\,\\\\,g; s,\$,$$,g -EOF_SED - program_transform_name="`echo $program_transform_name|sed -f conftestsed`" - rm -f conftestsed -fi -test "$program_prefix" != NONE && - program_transform_name="s,^,${program_prefix},; $program_transform_name" -# Use a double $ so make ignores it. -test "$program_suffix" != NONE && - program_transform_name="s,\$\$,${program_suffix},; $program_transform_name" - -# sed with no file args requires a program. -test "$program_transform_name" = "" && program_transform_name="s,x,x," - -echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 -echo "configure:663: checking whether ${MAKE-make} sets \${MAKE}" >&5 -set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftestmake <<\EOF -all: - @echo 'ac_maketemp="${MAKE}"' -EOF -# GNU make sometimes prints "make[1]: Entering...", which would confuse us. -eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=` -if test -n "$ac_maketemp"; then - eval ac_cv_prog_make_${ac_make}_set=yes -else - eval ac_cv_prog_make_${ac_make}_set=no -fi -rm -f conftestmake -fi -if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then - echo "$ac_t""yes" 1>&6 - SET_MAKE= -else - echo "$ac_t""no" 1>&6 - SET_MAKE="MAKE=${MAKE-make}" -fi - -ac_aux_dir= -for ac_dir in .. $srcdir/..; do - if test -f $ac_dir/install-sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f $ac_dir/install.sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - fi -done -if test -z "$ac_aux_dir"; then - { echo "configure: error: can not find install-sh or install.sh in .. $srcdir/.." 1>&2; exit 1; } -fi -ac_config_guess=$ac_aux_dir/config.guess -ac_config_sub=$ac_aux_dir/config.sub -ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. - -module=libguile - - -#-------------------------------------------------------------------- -# -# User options -# -#-------------------------------------------------------------------- - -# Check whether --enable-debug or --disable-debug was given. -if test "${enable_debug+set}" = set; then - enableval="$enable_debug" - : -fi - -if test "$enableval" != n && test "$enableval" != no; then - cat >> confdefs.h <<\EOF -#define DEBUG_EXTENSIONS 1 -EOF - - cat >> confdefs.h <<\EOF -#define READER_EXTENSIONS 1 -EOF - - LIBOBJS="backtrace.o stacks.o debug.o srcprop.o $LIBOBJS" -fi - -# Check whether --enable-dynamic-linking or --disable-dynamic-linking was given. -if test "${enable_dynamic_linking+set}" = set; then - enableval="$enable_dynamic_linking" - : -fi - -if test "$enableval" != n && test "$enableval" != no && test "$enableval" != ""; then - cat >> confdefs.h <<\EOF -#define DYNAMIC_LINKING 1 -EOF - -fi - -#-------------------------------------------------------------------- - -# Extract the first word of "gcc", so it can be a program name with args. -set dummy gcc; ac_word=$2 -echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:753: checking for $ac_word" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - test -z "$ac_dir" && ac_dir=. - if test -f $ac_dir/$ac_word; then - ac_cv_prog_CC="gcc" - break - fi - done - IFS="$ac_save_ifs" -fi -fi -CC="$ac_cv_prog_CC" -if test -n "$CC"; then - echo "$ac_t""$CC" 1>&6 -else - echo "$ac_t""no" 1>&6 -fi - -if test -z "$CC"; then - # Extract the first word of "cc", so it can be a program name with args. -set dummy cc; ac_word=$2 -echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:782: checking for $ac_word" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" - ac_prog_rejected=no - for ac_dir in $PATH; do - test -z "$ac_dir" && ac_dir=. - if test -f $ac_dir/$ac_word; then - if test "$ac_dir/$ac_word" = "/usr/ucb/cc"; then - ac_prog_rejected=yes - continue - fi - ac_cv_prog_CC="cc" - break - fi - done - IFS="$ac_save_ifs" -if test $ac_prog_rejected = yes; then - # We found a bogon in the path, so make sure we never use it. - set dummy $ac_cv_prog_CC - shift - if test $# -gt 0; then - # We chose a different compiler from the bogus one. - # However, it has the same basename, so the bogon will be chosen - # first if we set CC to just the basename; use the full file name. - shift - set dummy "$ac_dir/$ac_word" "$@" - shift - ac_cv_prog_CC="$@" - fi -fi -fi -fi -CC="$ac_cv_prog_CC" -if test -n "$CC"; then - echo "$ac_t""$CC" 1>&6 -else - echo "$ac_t""no" 1>&6 -fi - - test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; } -fi - -echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:830: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 - -ac_ext=c -# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. -ac_cpp='$CPP $CPPFLAGS' -ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' -ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' -cross_compiling=$ac_cv_prog_cc_cross - -cat > conftest.$ac_ext <<EOF -#line 840 "configure" -#include "confdefs.h" -main(){return(0);} -EOF -if { (eval echo configure:844: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - ac_cv_prog_cc_works=yes - # If we can't run a trivial program, we are probably using a cross compiler. - if (./conftest; exit) 2>/dev/null; then - ac_cv_prog_cc_cross=no - else - ac_cv_prog_cc_cross=yes - fi -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - ac_cv_prog_cc_works=no -fi -rm -fr conftest* - -echo "$ac_t""$ac_cv_prog_cc_works" 1>&6 -if test $ac_cv_prog_cc_works = no; then - { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } -fi -echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:864: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 -echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 -cross_compiling=$ac_cv_prog_cc_cross - -echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:869: checking whether we are using GNU C" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.c <<EOF -#ifdef __GNUC__ - yes; -#endif -EOF -if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:878: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then - ac_cv_prog_gcc=yes -else - ac_cv_prog_gcc=no -fi -fi - -echo "$ac_t""$ac_cv_prog_gcc" 1>&6 - -if test $ac_cv_prog_gcc = yes; then - GCC=yes - ac_test_CFLAGS="${CFLAGS+set}" - ac_save_CFLAGS="$CFLAGS" - CFLAGS= - echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:893: checking whether ${CC-cc} accepts -g" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - echo 'void f(){}' > conftest.c -if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then - ac_cv_prog_cc_g=yes -else - ac_cv_prog_cc_g=no -fi -rm -f conftest* - -fi - -echo "$ac_t""$ac_cv_prog_cc_g" 1>&6 - if test "$ac_test_CFLAGS" = set; then - CFLAGS="$ac_save_CFLAGS" - elif test $ac_cv_prog_cc_g = yes; then - CFLAGS="-g -O2" - else - CFLAGS="-O2" - fi -else - GCC= - test "${CFLAGS+set}" = set || CFLAGS="-g" -fi - -echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 -echo "configure:921: checking how to run the C preprocessor" >&5 -# On Suns, sometimes $CPP names a directory. -if test -n "$CPP" && test -d "$CPP"; then - CPP= -fi -if test -z "$CPP"; then -if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - # This must be in double quotes, not single quotes, because CPP may get - # substituted into the Makefile and "${CC-cc}" will confuse make. - CPP="${CC-cc} -E" - # On the NeXT, cc -E runs the code through the compiler's parser, - # not just through cpp. - cat > conftest.$ac_ext <<EOF -#line 936 "configure" -#include "confdefs.h" -#include <assert.h> -Syntax Error -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:942: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - : -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - CPP="${CC-cc} -E -traditional-cpp" - cat > conftest.$ac_ext <<EOF -#line 953 "configure" -#include "confdefs.h" -#include <assert.h> -Syntax Error -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:959: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - : -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - CPP=/lib/cpp -fi -rm -f conftest* -fi -rm -f conftest* - ac_cv_prog_CPP="$CPP" -fi - CPP="$ac_cv_prog_CPP" -else - ac_cv_prog_CPP="$CPP" -fi -echo "$ac_t""$CPP" 1>&6 - -# Extract the first word of "ranlib", so it can be a program name with args. -set dummy ranlib; ac_word=$2 -echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:984: checking for $ac_word" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - if test -n "$RANLIB"; then - ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. -else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - test -z "$ac_dir" && ac_dir=. - if test -f $ac_dir/$ac_word; then - ac_cv_prog_RANLIB="ranlib" - break - fi - done - IFS="$ac_save_ifs" - test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" -fi -fi -RANLIB="$ac_cv_prog_RANLIB" -if test -n "$RANLIB"; then - echo "$ac_t""$RANLIB" 1>&6 -else - echo "$ac_t""no" 1>&6 -fi - - -echo $ac_n "checking for AIX""... $ac_c" 1>&6 -echo "configure:1012: checking for AIX" >&5 -cat > conftest.$ac_ext <<EOF -#line 1014 "configure" -#include "confdefs.h" -#ifdef _AIX - yes -#endif - -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "yes" >/dev/null 2>&1; then - rm -rf conftest* - echo "$ac_t""yes" 1>&6; cat >> confdefs.h <<\EOF -#define _ALL_SOURCE 1 -EOF - -else - rm -rf conftest* - echo "$ac_t""no" 1>&6 -fi -rm -f conftest* - - -echo $ac_n "checking for POSIXized ISC""... $ac_c" 1>&6 -echo "configure:1036: checking for POSIXized ISC" >&5 -if test -d /etc/conf/kconfig.d && - grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1 -then - echo "$ac_t""yes" 1>&6 - ISC=yes # If later tests want to check for ISC. - cat >> confdefs.h <<\EOF -#define _POSIX_SOURCE 1 -EOF - - if test "$GCC" = yes; then - CC="$CC -posix" - else - CC="$CC -Xp" - fi -else - echo "$ac_t""no" 1>&6 - ISC= -fi - -ac_safe=`echo "minix/config.h" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for minix/config.h""... $ac_c" 1>&6 -echo "configure:1058: checking for minix/config.h" >&5 -if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1063 "configure" -#include "confdefs.h" -#include <minix/config.h> -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1068: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -fi -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - MINIX=yes -else - echo "$ac_t""no" 1>&6 -MINIX= -fi - -if test "$MINIX" = yes; then - cat >> confdefs.h <<\EOF -#define _POSIX_SOURCE 1 -EOF - - cat >> confdefs.h <<\EOF -#define _POSIX_1_SOURCE 2 -EOF - - cat >> confdefs.h <<\EOF -#define _MINIX 1 -EOF - -fi - - - -echo $ac_n "checking "threads package type"""... $ac_c" 1>&6 -echo "configure:1108: checking "threads package type"" >&5 -if eval "test \"`echo '$''{'cy_cv_threads_package'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - -if eval "test \"`echo '$''{'cy_cv_threads_cflags'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - -if eval "test \"`echo '$''{'cy_cv_threads_libs'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - -use_threads=no; -# Check whether --with-threads or --without-threads was given. -if test "${with_threads+set}" = set; then - withval="$with_threads" - use_threads=$withval -else - use_threads=no -fi - -test -n "$use_threads" || use_threads=qt -threads_package=unknown -if test "$use_threads" != no; then - if test "$use_threads" = yes || test "$use_threads" = qt; then - # Look for qt in source directory. This is a hack: we look in - # "./qt" because this check might be run at the top level. - if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then - threads_package=COOP - cy_cv_threads_cflags="-I$srcdir/../qt -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - else - if test -f $use_threads/qt.c; then - # FIXME seems as though we should try to use an installed qt here. - threads_package=COOP - cy_cv_threads_cflags="-I$use_threads -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - fi - if test "$use_threads" = pthreads; then - # Look for pthreads in srcdir. See above to understand why - # we always set threads_package. - if test -f $srcdir/../../pthreads/pthreads/queue.c \ - || test -f $srcdir/../pthreads/pthreads/queue.c; then - threads_package=MIT - cy_cv_threads_cflags="-I$srcdir/../../pthreads/include" - cy_cv_threads_libs="-L../../pthreads/lib -lpthread" - fi - fi - saved_CPP="$CPPFLAGS" - saved_LD="$LDFLAGS" - saved_LIBS="$LIBS" - if test "$threads_package" = unknown; then - CPPFLAGS="-I$use_threads/include" - LDFLAGS="-L$use_threads/lib" - LIBS="-lgthreads -lmalloc" - cat > conftest.$ac_ext <<EOF -#line 1167 "configure" -#include "confdefs.h" -#include <pthread.h> -int main() { - -pthread_equal(NULL,NULL); - -; return 0; } -EOF -if { (eval echo configure:1176: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - threads_package=FSU -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* - fi - if test "$threads_package" = unknown; then - LIBS="-lpthread" - cat > conftest.$ac_ext <<EOF -#line 1188 "configure" -#include "confdefs.h" -#include <pthread.h> -int main() { - -pthread_equal(NULL,NULL); - -; return 0; } -EOF -if { (eval echo configure:1197: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - threads_package=MIT -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* - fi - if test "$threads_package" = unknown; then - LIBS="-lpthreads" - cat > conftest.$ac_ext <<EOF -#line 1209 "configure" -#include "confdefs.h" -#include <pthread.h> -int main() { - -pthread_equal(NULL,NULL); - -; return 0; } -EOF -if { (eval echo configure:1218: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - threads_package=PCthreads -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* - fi - cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags" - cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs" - cy_cv_threads_package=$threads_package - CPPFLAGS="$saved_CPP" - LDFLAGS="$saved_LD" - LIBS="$saved_LIBS" - if test "$threads_package" = unknown; then - { echo "configure: error: "cannot find thread library installation"" 1>&2; exit 1; } - fi -fi - -fi - - -fi - - -fi - -echo "$ac_t""$cy_cv_threads_package" 1>&6 - - -echo $ac_n "checking for working const""... $ac_c" 1>&6 -echo "configure:1250: checking for working const" >&5 -if eval "test \"`echo '$''{'ac_cv_c_const'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1255 "configure" -#include "confdefs.h" - -int main() { - -/* Ultrix mips cc rejects this. */ -typedef int charset[2]; const charset x; -/* SunOS 4.1.1 cc rejects this. */ -char const *const *ccp; -char **p; -/* NEC SVR4.0.2 mips cc rejects this. */ -struct point {int x, y;}; -static struct point const zero = {0,0}; -/* AIX XL C 1.02.0.0 rejects this. - It does not let you subtract one const X* pointer from another in an arm - of an if-expression whose if-part is not a constant expression */ -const char *g = "string"; -ccp = &g + (g ? g-g : 0); -/* HPUX 7.0 cc rejects these. */ -++ccp; -p = (char**) ccp; -ccp = (char const *const *) p; -{ /* SCO 3.2v4 cc rejects this. */ - char *t; - char const *s = 0 ? (char *) 0 : (char const *) 0; - - *t++ = 0; -} -{ /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */ - int x[] = {25, 17}; - const int *foo = &x[0]; - ++foo; -} -{ /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */ - typedef const int *iptr; - iptr p = 0; - ++p; -} -{ /* AIX XL C 1.02.0.0 rejects this saying - "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */ - struct s { int j; const int *ap[3]; }; - struct s *b; b->j = 5; -} -{ /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ - const int foo = 10; -} - -; return 0; } -EOF -if { (eval echo configure:1304: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_c_const=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_c_const=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_c_const" 1>&6 -if test $ac_cv_c_const = no; then - cat >> confdefs.h <<\EOF -#define const -EOF - -fi - - -echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 -echo "configure:1326: checking for ANSI C header files" >&5 -if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1331 "configure" -#include "confdefs.h" -#include <stdlib.h> -#include <stdarg.h> -#include <string.h> -#include <float.h> -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1339: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - ac_cv_header_stdc=yes -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_header_stdc=no -fi -rm -f conftest* - -if test $ac_cv_header_stdc = yes; then - # SunOS 4.x string.h does not declare mem*, contrary to ANSI. -cat > conftest.$ac_ext <<EOF -#line 1356 "configure" -#include "confdefs.h" -#include <string.h> -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "memchr" >/dev/null 2>&1; then - : -else - rm -rf conftest* - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. -cat > conftest.$ac_ext <<EOF -#line 1374 "configure" -#include "confdefs.h" -#include <stdlib.h> -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "free" >/dev/null 2>&1; then - : -else - rm -rf conftest* - ac_cv_header_stdc=no -fi -rm -f conftest* - -fi - -if test $ac_cv_header_stdc = yes; then - # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. -if test "$cross_compiling" = yes; then - : -else - cat > conftest.$ac_ext <<EOF -#line 1395 "configure" -#include "confdefs.h" -#include <ctype.h> -#define ISLOWER(c) ('a' <= (c) && (c) <= 'z') -#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) -#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) -int main () { int i; for (i = 0; i < 256; i++) -if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); -exit (0); } - -EOF -if { (eval echo configure:1406: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null -then - : -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -fr conftest* - ac_cv_header_stdc=no -fi -rm -fr conftest* -fi - -fi -fi - -echo "$ac_t""$ac_cv_header_stdc" 1>&6 -if test $ac_cv_header_stdc = yes; then - cat >> confdefs.h <<\EOF -#define STDC_HEADERS 1 -EOF - -fi - -ac_header_dirent=no -for ac_hdr in dirent.h sys/ndir.h sys/dir.h ndir.h -do -ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for $ac_hdr that defines DIR""... $ac_c" 1>&6 -echo "configure:1434: checking for $ac_hdr that defines DIR" >&5 -if eval "test \"`echo '$''{'ac_cv_header_dirent_$ac_safe'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1439 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <$ac_hdr> -int main() { -DIR *dirp = 0; -; return 0; } -EOF -if { (eval echo configure:1447: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - eval "ac_cv_header_dirent_$ac_safe=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_dirent_$ac_safe=no" -fi -rm -f conftest* -fi -if eval "test \"`echo '$ac_cv_header_dirent_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'` - cat >> confdefs.h <<EOF -#define $ac_tr_hdr 1 -EOF - ac_header_dirent=$ac_hdr; break -else - echo "$ac_t""no" 1>&6 -fi -done -# Two versions of opendir et al. are in -ldir and -lx on SCO Xenix. -if test $ac_header_dirent = dirent.h; then -echo $ac_n "checking for opendir in -ldir""... $ac_c" 1>&6 -echo "configure:1472: checking for opendir in -ldir" >&5 -ac_lib_var=`echo dir'_'opendir | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - ac_save_LIBS="$LIBS" -LIBS="-ldir $LIBS" -cat > conftest.$ac_ext <<EOF -#line 1480 "configure" -#include "confdefs.h" -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char opendir(); - -int main() { -opendir() -; return 0; } -EOF -if { (eval echo configure:1491: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -LIBS="$ac_save_LIBS" - -fi -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then - echo "$ac_t""yes" 1>&6 - LIBS="$LIBS -ldir" -else - echo "$ac_t""no" 1>&6 -fi - -else -echo $ac_n "checking for opendir in -lx""... $ac_c" 1>&6 -echo "configure:1513: checking for opendir in -lx" >&5 -ac_lib_var=`echo x'_'opendir | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - ac_save_LIBS="$LIBS" -LIBS="-lx $LIBS" -cat > conftest.$ac_ext <<EOF -#line 1521 "configure" -#include "confdefs.h" -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char opendir(); - -int main() { -opendir() -; return 0; } -EOF -if { (eval echo configure:1532: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -LIBS="$ac_save_LIBS" - -fi -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then - echo "$ac_t""yes" 1>&6 - LIBS="$LIBS -lx" -else - echo "$ac_t""no" 1>&6 -fi - -fi - -echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6 -echo "configure:1555: checking whether time.h and sys/time.h may both be included" >&5 -if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1560 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <sys/time.h> -#include <time.h> -int main() { -struct tm *tp; -; return 0; } -EOF -if { (eval echo configure:1569: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_header_time=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_header_time=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_header_time" 1>&6 -if test $ac_cv_header_time = yes; then - cat >> confdefs.h <<\EOF -#define TIME_WITH_SYS_TIME 1 -EOF - -fi - -echo $ac_n "checking for sys/wait.h that is POSIX.1 compatible""... $ac_c" 1>&6 -echo "configure:1590: checking for sys/wait.h that is POSIX.1 compatible" >&5 -if eval "test \"`echo '$''{'ac_cv_header_sys_wait_h'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1595 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <sys/wait.h> -#ifndef WEXITSTATUS -#define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8) -#endif -#ifndef WIFEXITED -#define WIFEXITED(stat_val) (((stat_val) & 255) == 0) -#endif -int main() { -int s; -wait (&s); -s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; -; return 0; } -EOF -if { (eval echo configure:1611: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_header_sys_wait_h=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_header_sys_wait_h=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_header_sys_wait_h" 1>&6 -if test $ac_cv_header_sys_wait_h = yes; then - cat >> confdefs.h <<\EOF -#define HAVE_SYS_WAIT_H 1 -EOF - -fi - -for ac_hdr in libc.h limits.h malloc.h memory.h string.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/types.h sys/utime.h time.h unistd.h utime.h -do -ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:1635: checking for $ac_hdr" >&5 -if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1640 "configure" -#include "confdefs.h" -#include <$ac_hdr> -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1645: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -fi -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'` - cat >> confdefs.h <<EOF -#define $ac_tr_hdr 1 -EOF - -else - echo "$ac_t""no" 1>&6 -fi -done - - - for ac_hdr in libc.h unistd.h -do -ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` -echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 -echo "configure:1676: checking for $ac_hdr" >&5 -if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1681 "configure" -#include "confdefs.h" -#include <$ac_hdr> -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:1686: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - eval "ac_cv_header_$ac_safe=yes" -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_header_$ac_safe=no" -fi -rm -f conftest* -fi -if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'` - cat >> confdefs.h <<EOF -#define $ac_tr_hdr 1 -EOF - -else - echo "$ac_t""no" 1>&6 -fi -done - - echo $ac_n "checking "whether libc.h and unistd.h can be included together"""... $ac_c" 1>&6 -echo "configure:1713: checking "whether libc.h and unistd.h can be included together"" >&5 -if eval "test \"`echo '$''{'guile_cv_header_libc_with_unistd'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - - if test "$ac_cv_header_libc_h" = "no"; then - guile_cv_header_libc_with_unistd="no" - elif test "$ac_cv_header_unistd.h" = "no"; then - guile_cv_header_libc_with_unistd="yes" - else - cat > conftest.$ac_ext <<EOF -#line 1724 "configure" -#include "confdefs.h" - -# include <libc.h> -# include <unistd.h> - -int main() { - -; return 0; } -EOF -if { (eval echo configure:1734: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - guile_cv_header_libc_with_unistd=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - guile_cv_header_libc_with_unistd=no - -fi -rm -f conftest* - fi - - -fi - -echo "$ac_t""$guile_cv_header_libc_with_unistd" 1>&6 - if test "$guile_cv_header_libc_with_unistd" = yes; then - cat >> confdefs.h <<\EOF -#define LIBC_H_WITH_UNISTD_H 1 -EOF - - fi - - - -echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 -echo "configure:1761: checking for uid_t in sys/types.h" >&5 -if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1766 "configure" -#include "confdefs.h" -#include <sys/types.h> -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "uid_t" >/dev/null 2>&1; then - rm -rf conftest* - ac_cv_type_uid_t=yes -else - rm -rf conftest* - ac_cv_type_uid_t=no -fi -rm -f conftest* - -fi - -echo "$ac_t""$ac_cv_type_uid_t" 1>&6 -if test $ac_cv_type_uid_t = no; then - cat >> confdefs.h <<\EOF -#define uid_t int -EOF - - cat >> confdefs.h <<\EOF -#define gid_t int -EOF - -fi - -echo $ac_n "checking type of array argument to getgroups""... $ac_c" 1>&6 -echo "configure:1795: checking type of array argument to getgroups" >&5 -if eval "test \"`echo '$''{'ac_cv_type_getgroups'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - if test "$cross_compiling" = yes; then - ac_cv_type_getgroups=cross -else - cat > conftest.$ac_ext <<EOF -#line 1803 "configure" -#include "confdefs.h" - -/* Thanks to Mike Rendell for this test. */ -#include <sys/types.h> -#define NGID 256 -#undef MAX -#define MAX(x, y) ((x) > (y) ? (x) : (y)) -main() -{ - gid_t gidset[NGID]; - int i, n; - union { gid_t gval; long lval; } val; - - val.lval = -1; - for (i = 0; i < NGID; i++) - gidset[i] = val.gval; - n = getgroups (sizeof (gidset) / MAX (sizeof (int), sizeof (gid_t)) - 1, - gidset); - /* Exit non-zero if getgroups seems to require an array of ints. This - happens when gid_t is short but getgroups modifies an array of ints. */ - exit ((n > 0 && gidset[n] != val.gval) ? 1 : 0); -} - -EOF -if { (eval echo configure:1828: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null -then - ac_cv_type_getgroups=gid_t -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -fr conftest* - ac_cv_type_getgroups=int -fi -rm -fr conftest* -fi - -if test $ac_cv_type_getgroups = cross; then - cat > conftest.$ac_ext <<EOF -#line 1842 "configure" -#include "confdefs.h" -#include <unistd.h> -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "getgroups.*int.*gid_t" >/dev/null 2>&1; then - rm -rf conftest* - ac_cv_type_getgroups=gid_t -else - rm -rf conftest* - ac_cv_type_getgroups=int -fi -rm -f conftest* - -fi -fi - -echo "$ac_t""$ac_cv_type_getgroups" 1>&6 -cat >> confdefs.h <<EOF -#define GETGROUPS_T $ac_cv_type_getgroups -EOF - - -echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6 -echo "configure:1866: checking return type of signal handlers" >&5 -if eval "test \"`echo '$''{'ac_cv_type_signal'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1871 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <signal.h> -#ifdef signal -#undef signal -#endif -#ifdef __cplusplus -extern "C" void (*signal (int, void (*)(int)))(int); -#else -void (*signal ()) (); -#endif - -int main() { -int i; -; return 0; } -EOF -if { (eval echo configure:1888: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_type_signal=void -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_type_signal=int -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_type_signal" 1>&6 -cat >> confdefs.h <<EOF -#define RETSIGTYPE $ac_cv_type_signal -EOF - - -echo $ac_n "checking for mode_t""... $ac_c" 1>&6 -echo "configure:1907: checking for mode_t" >&5 -if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1912 "configure" -#include "confdefs.h" -#include <sys/types.h> -#if STDC_HEADERS -#include <stdlib.h> -#include <stddef.h> -#endif -EOF -if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - egrep "mode_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then - rm -rf conftest* - ac_cv_type_mode_t=yes -else - rm -rf conftest* - ac_cv_type_mode_t=no -fi -rm -f conftest* - -fi -echo "$ac_t""$ac_cv_type_mode_t" 1>&6 -if test $ac_cv_type_mode_t = no; then - cat >> confdefs.h <<\EOF -#define mode_t int -EOF - -fi - - -for ac_func in ctermid ftime getcwd geteuid lstat mkdir mknod nice putenv readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid -do -echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:1943: checking for $ac_func" >&5 -if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 1948 "configure" -#include "confdefs.h" -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func(); below. */ -#include <assert.h> -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func(); - -int main() { - -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -$ac_func(); -#endif - -; return 0; } -EOF -if { (eval echo configure:1971: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_func_$ac_func=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_func_$ac_func=no" -fi -rm -f conftest* -fi - -if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'` - cat >> confdefs.h <<EOF -#define $ac_tr_func 1 -EOF - -else - echo "$ac_t""no" 1>&6 -fi -done - - -for ac_func in inet_aton strerror -do -echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:1999: checking for $ac_func" >&5 -if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2004 "configure" -#include "confdefs.h" -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func(); below. */ -#include <assert.h> -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func(); - -int main() { - -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -$ac_func(); -#endif - -; return 0; } -EOF -if { (eval echo configure:2027: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_func_$ac_func=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_func_$ac_func=no" -fi -rm -f conftest* -fi - -if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'` - cat >> confdefs.h <<EOF -#define $ac_tr_func 1 -EOF - -else - echo "$ac_t""no" 1>&6 -LIBOBJS="$LIBOBJS ${ac_func}.o" -fi -done - - - -echo $ac_n "checking for st_rdev in struct stat""... $ac_c" 1>&6 -echo "configure:2055: checking for st_rdev in struct stat" >&5 -if eval "test \"`echo '$''{'ac_cv_struct_st_rdev'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2060 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <sys/stat.h> -int main() { -struct stat s; s.st_rdev; -; return 0; } -EOF -if { (eval echo configure:2068: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_struct_st_rdev=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_struct_st_rdev=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_struct_st_rdev" 1>&6 -if test $ac_cv_struct_st_rdev = yes; then - cat >> confdefs.h <<\EOF -#define HAVE_ST_RDEV 1 -EOF - -fi - -echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6 -echo "configure:2089: checking for st_blksize in struct stat" >&5 -if eval "test \"`echo '$''{'ac_cv_struct_st_blksize'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2094 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <sys/stat.h> -int main() { -struct stat s; s.st_blksize; -; return 0; } -EOF -if { (eval echo configure:2102: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_struct_st_blksize=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_struct_st_blksize=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_struct_st_blksize" 1>&6 -if test $ac_cv_struct_st_blksize = yes; then - cat >> confdefs.h <<\EOF -#define HAVE_ST_BLKSIZE 1 -EOF - -fi - -echo $ac_n "checking for st_blocks in struct stat""... $ac_c" 1>&6 -echo "configure:2123: checking for st_blocks in struct stat" >&5 -if eval "test \"`echo '$''{'ac_cv_struct_st_blocks'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2128 "configure" -#include "confdefs.h" -#include <sys/types.h> -#include <sys/stat.h> -int main() { -struct stat s; s.st_blocks; -; return 0; } -EOF -if { (eval echo configure:2136: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - ac_cv_struct_st_blocks=yes -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - ac_cv_struct_st_blocks=no -fi -rm -f conftest* -fi - -echo "$ac_t""$ac_cv_struct_st_blocks" 1>&6 -if test $ac_cv_struct_st_blocks = yes; then - cat >> confdefs.h <<\EOF -#define HAVE_ST_BLOCKS 1 -EOF - -else - LIBOBJS="$LIBOBJS fileblocks.o" -fi - - - echo $ac_n "checking whether we need POSIX to get struct utimbuf""... $ac_c" 1>&6 -echo "configure:2160: checking whether we need POSIX to get struct utimbuf" >&5 -if eval "test \"`echo '$''{'guile_cv_struct_utimbuf_needs_posix'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2165 "configure" -#include "confdefs.h" - -#ifdef __EMX__ -#include <sys/utime.h> -#else -#include <utime.h> -#endif -struct utime blah; - -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:2177: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - rm -rf conftest* - guile_cv_struct_utimbuf_needs_posix=no -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - guile_cv_struct_utimbuf_needs_posix=yes -fi -rm -f conftest* -fi - -echo "$ac_t""$guile_cv_struct_utimbuf_needs_posix" 1>&6 - if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then - cat >> confdefs.h <<\EOF -#define UTIMBUF_NEEDS_POSIX 1 -EOF - - fi - -# Checks for dynamic linking -echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6 -echo "configure:2202: checking for dlopen in -ldl" >&5 -ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - ac_save_LIBS="$LIBS" -LIBS="-ldl $LIBS" -cat > conftest.$ac_ext <<EOF -#line 2210 "configure" -#include "confdefs.h" -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char dlopen(); - -int main() { -dlopen() -; return 0; } -EOF -if { (eval echo configure:2221: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -LIBS="$ac_save_LIBS" - -fi -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_lib=HAVE_LIB`echo dl | sed -e 's/[^a-zA-Z0-9_]/_/g' \ - -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'` - cat >> confdefs.h <<EOF -#define $ac_tr_lib 1 -EOF - - LIBS="-ldl $LIBS" - -else - echo "$ac_t""no" 1>&6 -fi - -echo $ac_n "checking for dld_link in -ldld""... $ac_c" 1>&6 -echo "configure:2249: checking for dld_link in -ldld" >&5 -ac_lib_var=`echo dld'_'dld_link | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - ac_save_LIBS="$LIBS" -LIBS="-ldld $LIBS" -cat > conftest.$ac_ext <<EOF -#line 2257 "configure" -#include "confdefs.h" -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char dld_link(); - -int main() { -dld_link() -; return 0; } -EOF -if { (eval echo configure:2268: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_lib_$ac_lib_var=no" -fi -rm -f conftest* -LIBS="$ac_save_LIBS" - -fi -if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_lib=HAVE_LIB`echo dld | sed -e 's/[^a-zA-Z0-9_]/_/g' \ - -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'` - cat >> confdefs.h <<EOF -#define $ac_tr_lib 1 -EOF - - LIBS="-ldld $LIBS" - -else - echo "$ac_t""no" 1>&6 -fi - -for ac_func in shl_load -do -echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 -echo "configure:2298: checking for $ac_func" >&5 -if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2303 "configure" -#include "confdefs.h" -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func(); below. */ -#include <assert.h> -/* Override any gcc2 internal prototype to avoid an error. */ -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func(); - -int main() { - -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -$ac_func(); -#endif - -; return 0; } -EOF -if { (eval echo configure:2326: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - eval "ac_cv_func_$ac_func=yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - eval "ac_cv_func_$ac_func=no" -fi -rm -f conftest* -fi - -if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then - echo "$ac_t""yes" 1>&6 - ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'` - cat >> confdefs.h <<EOF -#define $ac_tr_func 1 -EOF - -else - echo "$ac_t""no" 1>&6 -fi -done - - -#-------------------------------------------------------------------- -# -# Which way does the stack grow? -# -#-------------------------------------------------------------------- - -if test "$cross_compiling" = yes; then - echo "configure: warning: Guessing that stack grows down -- see scmconfig.h.in" 1>&2 -else - cat > conftest.$ac_ext <<EOF -#line 2361 "configure" -#include "confdefs.h" -aux (l) unsigned long l; - { int x; exit (l >= ((unsigned long)&x)); } - main () { int q; aux((unsigned long)&q); } -EOF -if { (eval echo configure:2367: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null -then - cat >> confdefs.h <<\EOF -#define SCM_STACK_GROWS_UP 1 -EOF - -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -fr conftest* -fi - - - -if test "$cross_compiling" = yes; then - cat >> confdefs.h <<\EOF -#define SCM_SINGLES 1 -EOF - - echo "configure: warning: Guessing that sizeof(long) == sizeof(float) -- see scmconfig.h.in" 1>&2 -else - cat > conftest.$ac_ext <<EOF -#line 2390 "configure" -#include "confdefs.h" -main () { exit (sizeof(float) != sizeof(long)); } -EOF -if { (eval echo configure:2394: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null -then - cat >> confdefs.h <<\EOF -#define SCM_SINGLES 1 -EOF - -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -fr conftest* -fi - - -echo $ac_n "checking for struct linger""... $ac_c" 1>&6 -echo "configure:2409: checking for struct linger" >&5 -if eval "test \"`echo '$''{'scm_cv_struct_linger'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2414 "configure" -#include "confdefs.h" -#include <sys/socket.h> -int main() { -struct linger lgr; lgr.l_linger = 100 -; return 0; } -EOF -if { (eval echo configure:2421: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_linger="yes" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - scm_cv_struct_linger="no" -fi -rm -f conftest* -fi - -echo "$ac_t""$scm_cv_struct_linger" 1>&6 -if test $scm_cv_struct_linger = yes; then - cat >> confdefs.h <<\EOF -#define HAVE_STRUCT_LINGER 1 -EOF - -fi - -#-------------------------------------------------------------------- -# -# How can you violate a stdio abstraction by setting a stream's fd? -# -#-------------------------------------------------------------------- - -FD_SETTER="" - -if test "x$FD_SETTER" = x; then - cat > conftest.$ac_ext <<EOF -#line 2451 "configure" -#include "confdefs.h" -#include <stdio.h> - -int main() { -stdout->_file = 1 -; return 0; } -EOF -if { (eval echo configure:2459: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - FD_SETTER="((F)->_file = (D))" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* -fi - -if test "x$FD_SETTER" = x; then - cat > conftest.$ac_ext <<EOF -#line 2471 "configure" -#include "confdefs.h" -#include <stdio.h> - -int main() { -stdout->_fileno -; return 0; } -EOF -if { (eval echo configure:2479: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - FD_SETTER="((F)->_fileno = (D))" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* -fi - - -test "x$FD_SETTER" != x && cat >> confdefs.h <<\EOF -#define HAVE_FD_SETTER 1 -EOF - - -#-------------------------------------------------------------------- -# How to find out whether a FILE structure contains buffered data. -# From Tk we have the following list: -# _cnt: Most UNIX systems -# __cnt: HPUX -# _r: BSD -# readCount: Sprite -# Or, in GNU libc there are two fields, _gptr and _egptr, which -# have to be compared. -# These can also be known as _IO_read_ptr and _IO_read_end. -#-------------------------------------------------------------------- - -echo $ac_n "checking how to get buffer char count from FILE structure""... $ac_c" 1>&6 -echo "configure:2508: checking how to get buffer char count from FILE structure" >&5 -if eval "test \"`echo '$''{'scm_cv_struct_file_count'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2513 "configure" -#include "confdefs.h" -#include <stdio.h> -int main() { -FILE *f = stdin; f->_cnt = 0 -; return 0; } -EOF -if { (eval echo configure:2520: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_file_count="_cnt" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - cat > conftest.$ac_ext <<EOF -#line 2528 "configure" -#include "confdefs.h" -#include <stdio.h> -int main() { -FILE *f = stdin; f->_r = 0 -; return 0; } -EOF -if { (eval echo configure:2535: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_file_count="_r" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - cat > conftest.$ac_ext <<EOF -#line 2543 "configure" -#include "confdefs.h" -#include <stdio.h> -int main() { -FILE *f = stdin; f->readCount = 0 -; return 0; } -EOF -if { (eval echo configure:2550: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_file_count="readCount" -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - scm_cv_struct_file_count="" -fi -rm -f conftest* -fi -rm -f conftest* -fi -rm -f conftest* -fi - -if test "$scm_cv_struct_file_count"; then - echo "$ac_t""$scm_cv_struct_file_count" 1>&6 - cat >> confdefs.h <<EOF -#define FILE_CNT_FIELD $scm_cv_struct_file_count -EOF - -else -if eval "test \"`echo '$''{'scm_cv_struct_file_gptr'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2577 "configure" -#include "confdefs.h" -#include <stdio.h> -int main() { -FILE *f = stdin; f->_gptr = f->egptr; -; return 0; } -EOF -if { (eval echo configure:2584: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_file_gptr=1 -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - scm_cv_struct_file_gptr="" -fi -rm -f conftest* -fi - -if test "$scm_cv_struct_gptr"; then - echo "$ac_t""gptr" 1>&6 - cat >> confdefs.h <<EOF -#define FILE_CNT_GPTR $scm_cv_struct_file_gptr -EOF - -else -if eval "test \"`echo '$''{'scm_cv_struct_file_readptr'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.$ac_ext <<EOF -#line 2607 "configure" -#include "confdefs.h" -#include <stdio.h> -int main() { -FILE *f = stdin; f->_IO_read_ptr = f->_IO_read_end; -; return 0; } -EOF -if { (eval echo configure:2614: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then - rm -rf conftest* - scm_cv_struct_file_readptr=1 -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* -fi - -if test "$scm_cv_struct_file_readptr"; then - echo "$ac_t""read_ptr" 1>&6 - cat >> confdefs.h <<EOF -#define FILE_CNT_READPTR $scm_cv_struct_file_readptr -EOF - -fi -fi -fi - -#-------------------------------------------------------------------- -# -# Flags for thread support -# -#-------------------------------------------------------------------- - -if test "$cy_cv_threads_package" = FSU; then - cat >> confdefs.h <<\EOF -#define USE_FSU_PTHREADS 1 -EOF - - else if test "$cy_cv_threads_package" = COOP; then - cat >> confdefs.h <<\EOF -#define USE_COOP_THREADS 1 -EOF - - else if test "$cy_cv_threads_package" = MIT; then - cat >> confdefs.h <<\EOF -#define USE_MIT_PTHREADS 1 -EOF - - else if test "$cy_cv_threads_package" = PCthreads; then - cat >> confdefs.h <<\EOF -#define USE_PCTHREADS_PTHREADS 1 -EOF - - else if test "$cy_cv_threads_package" = unknown; then - { echo "configure: error: "cannot find threads installation"" 1>&2; exit 1; } - fi - fi - fi - fi -fi - -if test "$cy_cv_threads_package" != ""; then - cat >> confdefs.h <<\EOF -#define USE_THREADS 1 -EOF - -fi - -## If we're using GCC, ask for aggressive warnings. -case "$GCC" in - yes ) CFLAGS="$CFLAGS -Wall -Wpointer-arith" ;; -esac - -cat >> confdefs.h <<EOF -#define GUILE_MAJOR_VERSION "$GUILE_MAJOR_VERSION" -EOF - -cat >> confdefs.h <<EOF -#define GUILE_MINOR_VERSION "$GUILE_MINOR_VERSION" -EOF - -cat >> confdefs.h <<EOF -#define GUILE_VERSION "$GUILE_VERSION" -EOF - - - -trap '' 1 2 15 -cat > confcache <<\EOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs. It is not useful on other systems. -# If it contains results you don't want to keep, you may remove or edit it. -# -# By default, configure uses ./config.cache as the cache file, -# creating it if it does not exist already. You can give configure -# the --cache-file=FILE option to use a different cache file; that is -# what configure does when it calls configure scripts in -# subdirectories, so they share the cache. -# Giving --cache-file=/dev/null disables caching, for debugging configure. -# config.status only pays attention to the cache file if you give it the -# --recheck option to rerun configure. -# -EOF -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, don't put newlines in cache variables' values. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -(set) 2>&1 | - case `(ac_space=' '; set) 2>&1` in - *ac_space=\ *) - # `set' does not quote correctly, so add quotes (double-quote substitution - # turns \\\\ into \\, and sed turns \\ into \). - sed -n \ - -e "s/'/'\\\\''/g" \ - -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" - ;; - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' - ;; - esac >> confcache -if cmp -s $cache_file confcache; then - : -else - if test -w $cache_file; then - echo "updating cache $cache_file" - cat confcache > $cache_file - else - echo "not updating unwritable cache $cache_file" - fi -fi -rm -f confcache - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -# Any assignment to VPATH causes Sun make to only execute -# the first set of double-colon rules, so remove it if not needed. -# If there is a colon in the path, we need to keep it. -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' -fi - -trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 - -DEFS=-DHAVE_CONFIG_H - -# Without the "./", some shells look in PATH for config.status. -: ${CONFIG_STATUS=./config.status} - -echo creating $CONFIG_STATUS -rm -f $CONFIG_STATUS -cat > $CONFIG_STATUS <<EOF -#! /bin/sh -# Generated automatically by configure. -# Run this file to recreate the current configuration. -# This directory was configured as follows, -# on host `(hostname || uname -n) 2>/dev/null | sed 1q`: -# -# $0 $ac_configure_args -# -# Compiler output produced by configure, useful for debugging -# configure, is in ./config.log if it exists. - -ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" -for ac_option -do - case "\$ac_option" in - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" - exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; - -version | --version | --versio | --versi | --vers | --ver | --ve | --v) - echo "$CONFIG_STATUS generated by autoconf version 2.12" - exit 0 ;; - -help | --help | --hel | --he | --h) - echo "\$ac_cs_usage"; exit 0 ;; - *) echo "\$ac_cs_usage"; exit 1 ;; - esac -done - -ac_given_srcdir=$srcdir -ac_given_INSTALL="$INSTALL" - -trap 'rm -fr `echo "Makefile fd.h guile-snarf scmconfig.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 -EOF -cat >> $CONFIG_STATUS <<EOF - -# Protect against being on the right side of a sed subst in config.status. -sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g; - s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF -$ac_vpsub -$extrasub -s%@CFLAGS@%$CFLAGS%g -s%@CPPFLAGS@%$CPPFLAGS%g -s%@CXXFLAGS@%$CXXFLAGS%g -s%@DEFS@%$DEFS%g -s%@LDFLAGS@%$LDFLAGS%g -s%@LIBS@%$LIBS%g -s%@exec_prefix@%$exec_prefix%g -s%@prefix@%$prefix%g -s%@program_transform_name@%$program_transform_name%g -s%@bindir@%$bindir%g -s%@sbindir@%$sbindir%g -s%@libexecdir@%$libexecdir%g -s%@datadir@%$datadir%g -s%@sysconfdir@%$sysconfdir%g -s%@sharedstatedir@%$sharedstatedir%g -s%@localstatedir@%$localstatedir%g -s%@libdir@%$libdir%g -s%@includedir@%$includedir%g -s%@oldincludedir@%$oldincludedir%g -s%@infodir@%$infodir%g -s%@mandir@%$mandir%g -s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g -s%@INSTALL_DATA@%$INSTALL_DATA%g -s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g -s%@PACKAGE@%$PACKAGE%g -s%@VERSION@%$VERSION%g -s%@SET_MAKE@%$SET_MAKE%g -s%@module@%$module%g -s%@CC@%$CC%g -s%@CPP@%$CPP%g -s%@RANLIB@%$RANLIB%g -s%@LIBOBJS@%$LIBOBJS%g -s%@FD_SETTER@%$FD_SETTER%g - -CEOF -EOF - -cat >> $CONFIG_STATUS <<\EOF - -# Split the substitutions into bite-sized pieces for seds with -# small command number limits, like on Digital OSF/1 and HP-UX. -ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. -ac_file=1 # Number of current file. -ac_beg=1 # First line for current file. -ac_end=$ac_max_sed_cmds # Line after last line for current file. -ac_more_lines=: -ac_sed_cmds="" -while $ac_more_lines; do - if test $ac_beg -gt 1; then - sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file - else - sed "${ac_end}q" conftest.subs > conftest.s$ac_file - fi - if test ! -s conftest.s$ac_file; then - ac_more_lines=false - rm -f conftest.s$ac_file - else - if test -z "$ac_sed_cmds"; then - ac_sed_cmds="sed -f conftest.s$ac_file" - else - ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" - fi - ac_file=`expr $ac_file + 1` - ac_beg=$ac_end - ac_end=`expr $ac_end + $ac_max_sed_cmds` - fi -done -if test -z "$ac_sed_cmds"; then - ac_sed_cmds=cat -fi -EOF - -cat >> $CONFIG_STATUS <<EOF - -CONFIG_FILES=\${CONFIG_FILES-"Makefile fd.h guile-snarf"} -EOF -cat >> $CONFIG_STATUS <<\EOF -for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case "$ac_file" in - *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` - ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; - *) ac_file_in="${ac_file}.in" ;; - esac - - # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. - - # Remove last slash and all that follows it. Not all systems have dirname. - ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` - if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then - # The file is in a subdirectory. - test ! -d "$ac_dir" && mkdir "$ac_dir" - ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" - # A "../" for each directory in $ac_dir_suffix. - ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` - else - ac_dir_suffix= ac_dots= - fi - - case "$ac_given_srcdir" in - .) srcdir=. - if test -z "$ac_dots"; then top_srcdir=. - else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; - /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; - *) # Relative path. - srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" - top_srcdir="$ac_dots$ac_given_srcdir" ;; - esac - - case "$ac_given_INSTALL" in - [/$]*) INSTALL="$ac_given_INSTALL" ;; - *) INSTALL="$ac_dots$ac_given_INSTALL" ;; - esac - - echo creating "$ac_file" - rm -f "$ac_file" - configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." - case "$ac_file" in - *Makefile*) ac_comsub="1i\\ -# $configure_input" ;; - *) ac_comsub= ;; - esac - - ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` - sed -e "$ac_comsub -s%@configure_input@%$configure_input%g -s%@srcdir@%$srcdir%g -s%@top_srcdir@%$top_srcdir%g -s%@INSTALL@%$INSTALL%g -" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file -fi; done -rm -f conftest.s* - -# These sed commands are passed to sed as "A NAME B NAME C VALUE D", where -# NAME is the cpp macro being defined and VALUE is the value it is being given. -# -# ac_d sets the value in "#define NAME VALUE" lines. -ac_dA='s%^\([ ]*\)#\([ ]*define[ ][ ]*\)' -ac_dB='\([ ][ ]*\)[^ ]*%\1#\2' -ac_dC='\3' -ac_dD='%g' -# ac_u turns "#undef NAME" with trailing blanks into "#define NAME VALUE". -ac_uA='s%^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' -ac_uB='\([ ]\)%\1#\2define\3' -ac_uC=' ' -ac_uD='\4%g' -# ac_e turns "#undef NAME" without trailing blanks into "#define NAME VALUE". -ac_eA='s%^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' -ac_eB='$%\1#\2define\3' -ac_eC=' ' -ac_eD='%g' - -if test "${CONFIG_HEADERS+set}" != set; then -EOF -cat >> $CONFIG_STATUS <<EOF - CONFIG_HEADERS="scmconfig.h" -EOF -cat >> $CONFIG_STATUS <<\EOF -fi -for ac_file in .. $CONFIG_HEADERS; do if test "x$ac_file" != x..; then - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case "$ac_file" in - *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` - ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; - *) ac_file_in="${ac_file}.in" ;; - esac - - echo creating $ac_file - - rm -f conftest.frag conftest.in conftest.out - ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` - cat $ac_file_inputs > conftest.in - -EOF - -# Transform confdefs.h into a sed script conftest.vals that substitutes -# the proper values into config.h.in to produce config.h. And first: -# Protect against being on the right side of a sed subst in config.status. -# Protect against being in an unquoted here document in config.status. -rm -f conftest.vals -cat > conftest.hdr <<\EOF -s/[\\&%]/\\&/g -s%[\\$`]%\\&%g -s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%${ac_dA}\1${ac_dB}\1${ac_dC}\2${ac_dD}%gp -s%ac_d%ac_u%gp -s%ac_u%ac_e%gp -EOF -sed -n -f conftest.hdr confdefs.h > conftest.vals -rm -f conftest.hdr - -# This sed command replaces #undef with comments. This is necessary, for -# example, in the case of _POSIX_SOURCE, which is predefined and required -# on some systems where configure will not decide to define it. -cat >> conftest.vals <<\EOF -s%^[ ]*#[ ]*undef[ ][ ]*[a-zA-Z_][a-zA-Z_0-9]*%/* & */% -EOF - -# Break up conftest.vals because some shells have a limit on -# the size of here documents, and old seds have small limits too. - -rm -f conftest.tail -while : -do - ac_lines=`grep -c . conftest.vals` - # grep -c gives empty output for an empty file on some AIX systems. - if test -z "$ac_lines" || test "$ac_lines" -eq 0; then break; fi - # Write a limited-size here document to conftest.frag. - echo ' cat > conftest.frag <<CEOF' >> $CONFIG_STATUS - sed ${ac_max_here_lines}q conftest.vals >> $CONFIG_STATUS - echo 'CEOF - sed -f conftest.frag conftest.in > conftest.out - rm -f conftest.in - mv conftest.out conftest.in -' >> $CONFIG_STATUS - sed 1,${ac_max_here_lines}d conftest.vals > conftest.tail - rm -f conftest.vals - mv conftest.tail conftest.vals -done -rm -f conftest.vals - -cat >> $CONFIG_STATUS <<\EOF - rm -f conftest.frag conftest.h - echo "/* $ac_file. Generated automatically by configure. */" > conftest.h - cat conftest.in >> conftest.h - rm -f conftest.in - if cmp -s $ac_file conftest.h 2>/dev/null; then - echo "$ac_file is unchanged" - rm -f conftest.h - else - # Remove last slash and all that follows it. Not all systems have dirname. - ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` - if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then - # The file is in a subdirectory. - test ! -d "$ac_dir" && mkdir "$ac_dir" - fi - rm -f $ac_file - mv conftest.h $ac_file - fi -fi; done - -EOF -cat >> $CONFIG_STATUS <<EOF - - -EOF -cat >> $CONFIG_STATUS <<\EOF -test -z "$CONFIG_HEADER" || echo timestamp > stamp-h -chmod +x guile-snarf -exit 0 -EOF -chmod +x $CONFIG_STATUS -rm -fr confdefs* $ac_clean_files -test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 - - diff --git a/libguile/configure.in b/libguile/configure.in deleted file mode 100644 index d7ba37bd3..000000000 --- a/libguile/configure.in +++ /dev/null @@ -1,218 +0,0 @@ -AC_INIT(eval.c) -AM_CONFIG_HEADER(scmconfig.h) -AM_INIT_GUILE_MODULE(libguile) - -#-------------------------------------------------------------------- -# -# User options -# -#-------------------------------------------------------------------- - -AC_ARG_ENABLE(debug, -[ --disable-debug Don't include debugging support]) -if test "$enableval" != n && test "$enableval" != no; then - AC_DEFINE(DEBUG_EXTENSIONS) - AC_DEFINE(READER_EXTENSIONS) - LIBOBJS="backtrace.o stacks.o debug.o srcprop.o $LIBOBJS" -fi - -AC_ARG_ENABLE(dynamic-linking, - [ --enable-dynamic-linking Include support for dynamic linking]) -if test "$enableval" != n && test "$enableval" != no && test "$enableval" != ""; then - AC_DEFINE(DYNAMIC_LINKING) -fi - -#-------------------------------------------------------------------- - -AC_PROG_CC -AC_PROG_CPP -AC_PROG_RANLIB - -AC_AIX -AC_ISC_POSIX -AC_MINIX - -CY_AC_WITH_THREADS - -AC_C_CONST - -AC_HEADER_STDC -AC_HEADER_DIRENT -AC_HEADER_TIME -AC_HEADER_SYS_WAIT -AC_CHECK_HEADERS(libc.h limits.h malloc.h memory.h string.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/types.h sys/utime.h time.h unistd.h utime.h) -GUILE_HEADER_LIBC_WITH_UNISTD - -AC_TYPE_GETGROUPS -AC_TYPE_SIGNAL -AC_TYPE_MODE_T - -AC_CHECK_FUNCS(ctermid ftime getcwd geteuid lstat mkdir mknod nice putenv readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid) - -AC_REPLACE_FUNCS(inet_aton strerror) - -AC_STRUCT_ST_RDEV -AC_STRUCT_ST_BLKSIZE -AC_STRUCT_ST_BLOCKS -GUILE_STRUCT_UTIMBUF - -# Checks for dynamic linking -AC_CHECK_LIB(dl,dlopen) -AC_CHECK_LIB(dld,dld_link) -AC_CHECK_FUNCS(shl_load) - -#-------------------------------------------------------------------- -# -# Which way does the stack grow? -# -#-------------------------------------------------------------------- - -AC_TRY_RUN(aux (l) unsigned long l; - { int x; exit (l >= ((unsigned long)&x)); } - main () { int q; aux((unsigned long)&q); }, - AC_DEFINE(SCM_STACK_GROWS_UP),,AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h.in)) - - -AC_TRY_RUN(main () { exit (sizeof(float) != sizeof(long)); }, - AC_DEFINE(SCM_SINGLES),,AC_DEFINE(SCM_SINGLES) - AC_MSG_WARN(Guessing that sizeof(long) == sizeof(float) -- see scmconfig.h.in)) - -AC_MSG_CHECKING(for struct linger) -AC_CACHE_VAL(scm_cv_struct_linger, - AC_TRY_COMPILE([#include <sys/socket.h>], - [struct linger lgr; lgr.l_linger = 100], - scm_cv_struct_linger="yes", - scm_cv_struct_linger="no")) -AC_MSG_RESULT($scm_cv_struct_linger) -if test $scm_cv_struct_linger = yes; then - AC_DEFINE(HAVE_STRUCT_LINGER) -fi - -#-------------------------------------------------------------------- -# -# How can you violate a stdio abstraction by setting a stream's fd? -# -#-------------------------------------------------------------------- - -FD_SETTER="" - -if test "x$FD_SETTER" = x; then - AC_TRY_COMPILE(#include <stdio.h> -, stdout->_file = 1, - FD_SETTER="((F)->_file = (D))") -fi - -if test "x$FD_SETTER" = x; then - AC_TRY_COMPILE(#include <stdio.h> -, stdout->_fileno, - FD_SETTER="((F)->_fileno = (D))") -fi - -dnl -dnl Add FD_SETTER tests for other systems here. Your test should -dnl try a particular style of assigning to the descriptor -dnl field(s) of a FILE* and define FD_SETTER accordingly. -dnl -dnl The value of FD_SETTER is used as a macro body, as in: -dnl -dnl #define SET_FILE_FD_FIELD(F,D) @FD_SETTER@ -dnl -dnl F is a FILE* and D a descriptor (int). -dnl - -test "x$FD_SETTER" != x && AC_DEFINE(HAVE_FD_SETTER) - -#-------------------------------------------------------------------- -# How to find out whether a FILE structure contains buffered data. -# From Tk we have the following list: -# _cnt: Most UNIX systems -# __cnt: HPUX -# _r: BSD -# readCount: Sprite -# Or, in GNU libc there are two fields, _gptr and _egptr, which -# have to be compared. -# These can also be known as _IO_read_ptr and _IO_read_end. -#-------------------------------------------------------------------- - -AC_MSG_CHECKING(how to get buffer char count from FILE structure) -AC_CACHE_VAL(scm_cv_struct_file_count, - AC_TRY_COMPILE([#include <stdio.h>], - [FILE *f = stdin; f->_cnt = 0], - scm_cv_struct_file_count="_cnt", - AC_TRY_COMPILE([#include <stdio.h>], - [FILE *f = stdin; f->_r = 0], - scm_cv_struct_file_count="_r", - AC_TRY_COMPILE([#include <stdio.h>], - [FILE *f = stdin; f->readCount = 0], - scm_cv_struct_file_count="readCount", - scm_cv_struct_file_count="")))) -if test "$scm_cv_struct_file_count"; then - AC_MSG_RESULT($scm_cv_struct_file_count) - AC_DEFINE_UNQUOTED(FILE_CNT_FIELD, $scm_cv_struct_file_count) -else -AC_CACHE_VAL(scm_cv_struct_file_gptr, - AC_TRY_COMPILE([#include <stdio.h>], - [FILE *f = stdin; f->_gptr = f->egptr;], - scm_cv_struct_file_gptr=1, - scm_cv_struct_file_gptr="")) -if test "$scm_cv_struct_gptr"; then - AC_MSG_RESULT(gptr) - AC_DEFINE_UNQUOTED(FILE_CNT_GPTR, $scm_cv_struct_file_gptr) -else -AC_CACHE_VAL(scm_cv_struct_file_readptr, - AC_TRY_COMPILE([#include <stdio.h>], - [FILE *f = stdin; f->_IO_read_ptr = f->_IO_read_end;], - scm_cv_struct_file_readptr=1)) -if test "$scm_cv_struct_file_readptr"; then - AC_MSG_RESULT(read_ptr) - AC_DEFINE_UNQUOTED(FILE_CNT_READPTR, $scm_cv_struct_file_readptr) -fi -fi -fi - -#-------------------------------------------------------------------- -# -# Flags for thread support -# -#-------------------------------------------------------------------- - -dnl -dnl Set the appropriate flags! -dnl -if test "$cy_cv_threads_package" = FSU; then - AC_DEFINE(USE_FSU_PTHREADS, 1) - else if test "$cy_cv_threads_package" = COOP; then - AC_DEFINE(USE_COOP_THREADS, 1) - else if test "$cy_cv_threads_package" = MIT; then - AC_DEFINE(USE_MIT_PTHREADS, 1) - else if test "$cy_cv_threads_package" = PCthreads; then - AC_DEFINE(USE_PCTHREADS_PTHREADS, 1) - else if test "$cy_cv_threads_package" = unknown; then - AC_MSG_ERROR("cannot find threads installation") - fi - fi - fi - fi -fi - -if test "$cy_cv_threads_package" != ""; then - AC_DEFINE(USE_THREADS) -fi - -## If we're using GCC, ask for aggressive warnings. -case "$GCC" in - yes ) CFLAGS="$CFLAGS -Wall -Wpointer-arith" ;; -esac - -AC_DEFINE_UNQUOTED(GUILE_MAJOR_VERSION, "$GUILE_MAJOR_VERSION") -AC_DEFINE_UNQUOTED(GUILE_MINOR_VERSION, "$GUILE_MINOR_VERSION") -AC_DEFINE_UNQUOTED(GUILE_VERSION, "$GUILE_VERSION") - -AC_SUBST(FD_SETTER) -AC_OUTPUT([Makefile fd.h guile-snarf], [chmod +x guile-snarf]) - -dnl Local Variables: -dnl comment-start: "dnl " -dnl comment-end: "" -dnl comment-start-skip: "\\bdnl\\b\\s *" -dnl End: diff --git a/libguile/continuations.c b/libguile/continuations.c deleted file mode 100644 index f04912c8a..000000000 --- a/libguile/continuations.c +++ /dev/null @@ -1,212 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "stackchk.h" -#ifdef DEBUG_EXTENSIONS -#include "debug.h" -#endif -#include "dynwind.h" - -#include "continuations.h" - - -/* {Continuations} - */ - -static char s_cont[] = "continuation"; - - -SCM -scm_make_cont (answer) - SCM * answer; -{ - long j; - SCM cont; - -#ifdef CHEAP_CONTINUATIONS - SCM_NEWCELL (cont); - *answer = cont; - SCM_DEFER_INTS; - SCM_SETJMPBUF (cont, scm_must_malloc ((long) sizeof (scm_contregs), s_cont)); - SCM_SETCAR (cont, scm_tc7_contin); - SCM_DYNENV (cont) = scm_dynwinds; - SCM_THROW_VALUE = SCM_EOL; - SCM_BASE (cont) = SCM_BASE (rootcont); - SCM_SEQ (cont) = SCM_SEQ (rootcont); - SCM_ALLOW_INTS; -#else - register SCM_STACKITEM *src, *dst; - -#if 0 - { - SCM winds; - - for (winds = scm_dynwinds; winds != SCM_EOL; winds = SCM_CDR (winds)) - { - if (SCM_INUMP (SCM_CAR (winds))) - { - scm_relocate_chunk_to_heap (SCM_CAR (winds)); - } - } - } -#endif - - SCM_NEWCELL (cont); - *answer = cont; - SCM_DEFER_INTS; - SCM_FLUSH_REGISTER_WINDOWS; - j = scm_stack_size (SCM_BASE (scm_rootcont)); - SCM_SETJMPBUF (cont, - scm_must_malloc ((long) (sizeof (scm_contregs) + j * sizeof (SCM_STACKITEM)), - s_cont)); - SCM_SETLENGTH (cont, j, scm_tc7_contin); - SCM_DYNENV (cont) = scm_dynwinds; - SCM_THROW_VALUE (cont) = SCM_EOL; - src = SCM_BASE (cont) = SCM_BASE (scm_rootcont); - SCM_SEQ (cont) = SCM_SEQ (scm_rootcont); - SCM_ALLOW_INTS; -#ifndef SCM_STACK_GROWS_UP - src -= SCM_LENGTH (cont); -#endif /* ndef SCM_STACK_GROWS_UP */ - dst = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs)); - for (j = SCM_LENGTH (cont); 0 <= --j;) - *dst++ = *src++; -#endif /* def CHEAP_CONTINUATIONS */ -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (cont) = scm_last_debug_frame; -#endif - return cont; -} - -/* Grow the stack so that there is room */ -/* to copy in the continuation. Then */ -#ifndef CHEAP_CONTINUATIONS - -static void grow_throw SCM_P ((SCM *a)); - -static void -grow_throw (a) - SCM *a; -{ /* retry the throw. */ - SCM growth[100]; - growth[0] = a[0]; - growth[1] = a[1]; - growth[2] = a[2] + 1; - growth[3] = (SCM) a; - scm_dynthrow (growth); -} -#endif /* ndef CHEAP_CONTINUATIONS */ - - -void -scm_dynthrow (a) - SCM *a; -{ - SCM cont = a[0], val = a[1]; -#ifndef CHEAP_CONTINUATIONS - register long j; - register SCM_STACKITEM *src, *dst = SCM_BASE (scm_rootcont); -#ifdef SCM_STACK_GROWS_UP - if (a[2] && (a - ((SCM *) a[3]) < 100)) -#else - if (a[2] && (((SCM *) a[3]) - a < 100)) -#endif - fputs ("grow_throw: check if SCM growth[100]; being optimized out\n", - stderr); - /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", - a[2], (((SCM *)a[3]) - a)); */ -#ifdef SCM_STACK_GROWS_UP - if (SCM_PTR_GE (dst + SCM_LENGTH (cont), (SCM_STACKITEM *) & a)) - grow_throw (a); -#else - dst -= SCM_LENGTH (cont); - if (SCM_PTR_LE (dst, (SCM_STACKITEM *) & a)) - grow_throw (a); -#endif /* def SCM_STACK_GROWS_UP */ - SCM_FLUSH_REGISTER_WINDOWS; - src = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs)); - for (j = SCM_LENGTH (cont); 0 <= --j;) - *dst++ = *src++; -#ifdef sparc /* clear out stack up to this stackframe */ - /* maybe this would help, maybe not */ -/* bzero((void *)&a, sizeof(SCM_STACKITEM) * (((SCM_STACKITEM *)&a) - - (dst - SCM_LENGTH(cont)))) */ -#endif -#endif /* ndef CHEAP_CONTINUATIONS */ -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_DFRAME (cont); -#endif - SCM_THROW_VALUE(cont) = val; - longjmp (SCM_JMPBUF (cont), 1); -} - - -SCM -scm_call_continuation (cont, val) - SCM cont; - SCM val; -{ - SCM a[3]; - a[0] = cont; - a[1] = val; - a[2] = 0; - if ( (SCM_SEQ (cont) != SCM_SEQ (scm_rootcont)) - || (SCM_BASE (cont) != SCM_BASE (scm_rootcont))) /* base compare not needed */ - scm_wta (cont, "continuation from wrong top level", s_cont); - - scm_dowinds (SCM_DYNENV (cont), - scm_ilength (scm_dynwinds) - scm_ilength (SCM_DYNENV (cont))); - - scm_dynthrow (a); - return SCM_UNSPECIFIED; /* not reached */ -} - - - -void -scm_init_continuations () -{ -#include "continuations.x" -} - diff --git a/libguile/continuations.h b/libguile/continuations.h deleted file mode 100644 index 0bd18296e..000000000 --- a/libguile/continuations.h +++ /dev/null @@ -1,78 +0,0 @@ -/* classes: h_files */ - -#ifndef CONTINUATIONSH -#define CONTINUATIONSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -typedef struct -{ - SCM throw_value; - jmp_buf jmpbuf; - SCM dynenv; - SCM_STACKITEM *base; - unsigned long seq; - -#ifdef DEBUG_EXTENSIONS - struct scm_debug_frame *dframe; -#endif -} scm_contregs; - -#define SCM_JMPBUF(x) (((scm_contregs *)SCM_CHARS(x))->jmpbuf) -#define SCM_SETJMPBUF SCM_SETCDR -#define SCM_DYNENV(x) (((scm_contregs *)SCM_CHARS(x))->dynenv) -#define SCM_THROW_VALUE(x) (((scm_contregs *)SCM_CHARS(x))->throw_value) -#define SCM_BASE(x) (((scm_contregs *)SCM_CHARS(x))->base) -#define SCM_SEQ(x) (((scm_contregs *)SCM_CHARS(x))->seq) -#define SCM_DFRAME(x) (((scm_contregs *)SCM_CHARS(x))->dframe) - - - -extern SCM scm_make_cont SCM_P ((SCM * answer)); -extern void scm_dynthrow SCM_P ((SCM *a)); -extern SCM scm_call_continuation SCM_P ((SCM cont, SCM val)); -extern void scm_init_continuations SCM_P ((void)); - -#endif /* CONTINUATIONSH */ diff --git a/libguile/dynl-dl.c b/libguile/dynl-dl.c deleted file mode 100644 index 7899b3245..000000000 --- a/libguile/dynl-dl.c +++ /dev/null @@ -1,212 +0,0 @@ -/* dynl-dl.c - dynamic linking for dlopen/dlsym - * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - Modified for libguile by Marius Vollmer */ - -#include "_scm.h" -#include "genio.h" -#include "smob.h" - -#include <dlfcn.h> - -#define SHL(obj) ((void*)SCM_CDR(obj)) - -#ifdef RTLD_LAZY /* Solaris 2. */ -# define DLOPEN_MODE RTLD_LAZY -#else -# define DLOPEN_MODE 1 /* Thats what it says in the man page. */ -#endif - -static scm_sizet frshl SCM_P ((SCM ptr)); - -static scm_sizet -frshl (ptr) - SCM ptr; -{ -#if 0 - /* Should freeing a shl close and possibly unmap the object file it */ - /* refers to? */ - if (SHL(ptr)) - dlclose (SHL(ptr)); -#endif - return 0; -} - -static int prinshl SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinshl (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<dynamic-linked ", port); - scm_intprint (SCM_CDR (exp), 16, port); - scm_gen_putc ('>', port); - return 1; -} - -int scm_tc16_shl; -static scm_smobfuns shlsmob = { scm_mark0, frshl, prinshl }; - -SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link); - -SCM -scm_dynamic_link (fname) - SCM fname; -{ - SCM z; - void *handle; - - /* if FALSEP(fname) return fname; XXX - ? */ - - fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1); - - SCM_DEFER_INTS; - handle = dlopen (SCM_CHARS (fname), DLOPEN_MODE); - if (NULL == handle) - scm_misc_error (s_dynamic_link, (char *)dlerror (), SCM_EOL); - SCM_NEWCELL (z); - SCM_SETCHARS (z, handle); - SCM_SETCAR (z, scm_tc16_shl); - SCM_ALLOW_INTS; - - return z; -} - -static void *get_func SCM_P ((void *handle, char *func, char *subr)); - -static void * -get_func (handle, func, subr) - void *handle; - char *func; - char *subr; -{ - void *fptr; - char *err; - - fptr = dlsym (handle, func); - err = (char *)dlerror (); - if (!fptr) - scm_misc_error (subr, err? err : "symbol has NULL address", SCM_EOL); - return fptr; -} - -SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call); - -SCM -scm_dynamic_call (symb, shl) - SCM symb, shl; -{ - void (*func) SCM_P ((void)) = 0; - - symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1); - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, - SCM_ARG2, s_dynamic_call); - - SCM_DEFER_INTS; - func = get_func (SHL(shl), SCM_CHARS (symb), s_dynamic_call); - SCM_ALLOW_INTS; - - (*func) (); - - return SCM_BOOL_T; -} - -SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call); - -SCM -scm_dynamic_args_call (symb, shl, args) - SCM symb, shl, args; -{ - int i, argc; - char **argv; - int (*func) SCM_P ((int argc, char **argv)) = 0; - - symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1); - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, - SCM_ARG2, s_dynamic_args_call); - - SCM_DEFER_INTS; - func = get_func (SHL(shl), SCM_CHARS (symb), s_dynamic_args_call); - argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call, - SCM_ARG3); - SCM_ALLOW_INTS; - - i = (*func) (argc, argv); - - SCM_DEFER_INTS; - scm_must_free_argv(argv); - SCM_ALLOW_INTS; - return SCM_MAKINUM(0L+i); -} - -SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink); - -SCM -scm_dynamic_unlink (shl) - SCM shl; -{ - int status; - - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, - SCM_ARG1, s_dynamic_unlink); - - SCM_DEFER_INTS; - status = dlclose (SHL(shl)); - SCM_SETCHARS (shl, NULL); - SCM_ALLOW_INTS; - - if (status) - scm_misc_error (s_dynamic_unlink, (char *)dlerror (), SCM_EOL); - return SCM_BOOL_T; -} - -void -scm_init_dynamic_linking () -{ - scm_tc16_shl = scm_newsmob (&shlsmob); -#include "dynl.x" -} diff --git a/libguile/dynl-dld.c b/libguile/dynl-dld.c deleted file mode 100644 index aba8b93ed..000000000 --- a/libguile/dynl-dld.c +++ /dev/null @@ -1,187 +0,0 @@ -/* dynl-dld.c - dynamic linking with dld - * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - Modified for libguile by Marius Vollmer */ - -#include "_scm.h" -#include "genio.h" -#include "smob.h" - -#include "dld.h" - -static void listundef SCM_P ((void)); - -static void -listundefs () -{ - int i; - char **undefs = dld_list_undefined_sym(); - puts(" undefs:"); - for(i = dld_undefined_sym_count;i--;) { - putc('"', stdout); - fputs(undefs[i], stdout); - puts("\""); - } - free(undefs); -} - -SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link); - -SCM -scm_dynamic_link (fname) - SCM fname; -{ - int status; - - fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1); - - SCM_DEFER_INTS; - status = dld_link (SCM_CHARS (fname)); - SCM_ALLOW_INTS; - if (status) - scm_misc_error (s_dynamic_link, dld_strerror (status), SCM_EOL); - return fname; -} - -static void *get_func SCM_P ((char *subr, char *fname)); - -static void * -get_func (subr, fname) - char *subr; - char *fname; -{ - void *func; - - if (!dld_function_executable_p (func)) { - listundefs (); - scm_misc_error (subr, "unresolved symbols remain", SCM_EOL); - } - func = (void *) dld_get_func (func); - if (func == 0) - scm_misc_error (subr, dld_strerror (dld_errno), SCM_EOL); - return func; -} - -SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call); - -SCM -scm_dynamic_call (symb, shl) - SCM symb; - SCM shl; -{ - void (*func)() = 0; - - symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1); - - SCM_DEFER_INTS; - func = get_func (s_dynamic_call, SCM_CHARS (symb)); - SCM_ALLOW_INST; - (*func) (); - return SCM_BOOL_T; -} - -SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call); - -SCM -scm_dynamic_args_call (symb, shl, args) - SCM symb, shl, args; -{ - int i, argc; - char **argv; - int (*func) SCM_P ((int argc, char **argv)) = 0; - - symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1); - - SCM_DEFER_INTS; - func = get_func (SCM_CHARS (symb), s_dynamic_args_call); - argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call, - SCM_ARG3); - SCM_ALLOW_INTS; - - i = (*func) (argc, argv); - - SCM_DEFER_INTS; - scm_must_free_argv(argv); - SCM_ALLOW_INTS; - return SCM_MAKINUM(0L+i); -} - -SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink); - -SCM -scm_dynamic_unlink(fname) - SCM fname; -{ - int status; - - fname = scm_coerce_rostring (fname, s_dynamic_unlink, SCM_ARG1); - - SCM_DEFER_INTS; - status = dld_unlink_by_file (SCM_CHARS (fname), 1); - SCM_ALLOW_INTS; - - if (status) - scm_misc_error (s_dynamic_unlink, dld_strerror (status), SCM_EOL); - return SCM_BOOL_T; -} - -void -scm_init_dynamic_linking () -{ -#ifndef RTL - if (!execpath) - execpath = dld_find_executable (SCM_CHARS (SCM_CAR (progargs))); - if (dld_init (SCM_CHARS (SCM_CAR (progargs)))) { - dld_perror("DLD"); - return; - } -#endif - -#include "dynl.x" - -#ifdef DLD_DYNCM /* XXX - what's this? */ - add_feature("dld:dyncm"); -#endif -} diff --git a/libguile/dynl-shl.c b/libguile/dynl-shl.c deleted file mode 100644 index b8e474484..000000000 --- a/libguile/dynl-shl.c +++ /dev/null @@ -1,172 +0,0 @@ -/* dynl-shl.c - dynamic linking with shl_load (HP-UX) - * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - Modified for libguile by Marius Vollmer */ - -#include "_scm.h" -#include "genio.h" -#include "smob.h" - -#include "dl.h" - -#define SHL(obj) ((shl_t*)SCM_CDR(obj)) - -static int printshl SCM_P ((SCM exp, SCM port, scm_printstate *pstate)); - -static int -prinshl (exp, port, pstate) - SCM exp; - SCM port; - scm_printstate *pstate; -{ - scm_gen_puts (scm_regular_string, "#<dynamic-linked ", port); - scm_intprint (SCM_CDR (exp), 16, port); - scm_gen_putc ('>', port); - return 1; -} - -int scm_tc16_shl; -static scm_smobfuns shlsmob = { scm_mark0, scm_free0, prinshl }; - -SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link); - -SCM -scm_dynamic_link (fname) - SCM fname; -{ - SCM z; - shl_t shl; - - fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1); - - SCM_DEFER_INTS; - shl = shl_load (SCM_CHARS (fname), BIND_DEFERRED , 0L); - if (NULL==shl) - scm_misc_error (s_dynamic_link, "dynamic linking failed", SCM_EOL); - SCM_NEWCELL (z); - SCM_SETCHARS (z, shl); - SCM_SETCAR (z, scm_tc16_shl); - SCM_ALLOW_INTS; - - return z; -} - -SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call); - -SCM -scm_dynamic_call (symb, shl) - SCM symb, shl; -{ - void (*func)() = 0; - int i; - - symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1); - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, SCM_ARG2, - s_dynamic_call); - - SCM_DEFER_INTS; - if (shl_findsym (&SHL(shl), SCM_CHARS(symb), TYPE_PROCEDURE, &func)) - scm_misc_error (s_dynamic_call, "undefined function", - scm_cons (symb, SCM_EOL)); - SCM_ALLOW_INTS; - - (*func) (); - return SCM_BOOL_T; -} - -SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call); - -SCM -scm_dynamic_args_call (symb, shl, args) - SCM symb, shl, args; -{ - int i, argc; - char **argv; - int (*func) SCM_P ((int argc, char **argv)) = 0; - - symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1); - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR(shl) == scm_tc16_shl, shl, SCM_ARG2, - s_dynamic_args_call); - - SCM_DEFER_INTS; - if (shl_findsym(&SHL(shl), SCM_CHARS(symb), TYPE_PROCEDURE, &func)) - scm_misc_error (s_dynamic_call, "undefined function: %s", - scm_cons (symb, SCM_EOL)); - argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call, - SCM_ARG3); - SCM_ALLOW_INTS; - - i = (*func) (argc, argv); - - SCM_DEFER_INTS; - scm_must_free_argv (argv); - SCM_ALLOW_INTS; - return SCM_MAKINUM (0L+i); -} - -SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink); - -SCM -scm_dynamic_unlink (shl) - SCM shl; -{ - int status; - SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, - SCM_ARG1, s_dynamic_unlink); - - SCM_DEFER_INTS; - status = shl_unload (SHL (shl)); - SCM_ALLOW_INTS; - if (!status) - return SCM_BOOL_T; - return SCM_BOOL_F; -} - -void -scm_init_dynamic_linking () -{ - scm_tc16_shl = scm_newsmob (&shlsmob); -#include "dynl.x" -} diff --git a/libguile/dynl-vms.c b/libguile/dynl-vms.c deleted file mode 100644 index 322839cbc..000000000 --- a/libguile/dynl-vms.c +++ /dev/null @@ -1,106 +0,0 @@ -/* dynl-vms.c - dynamic linking for VMS, not yet ported - * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - (Not yet) modified for libguile by Marius Vollmer */ - -/* We should try to implement dynamic-link/dynamic-call for VMS, - too. */ - -#include "_scm.h" - -/* This permits dynamic linking. For example, the procedure of 0 arguments - from a file could be the initialization procedure. - (vms:dynamic-link-call "MYDISK:[MYDIR].EXE" "foo" "INIT_FOO") - The first argument specifies the directory where the file specified - by the second argument resides. The current directory would be - "SYS$DISK:[].EXE". - The second argument cannot contain any punctuation. - The third argument probably needs to be uppercased to mimic the VMS linker. - */ - -# include <descrip.h> -# include <ssdef.h> -# include <rmsdef.h> - -struct dsc$descriptor *descriptorize(x, buff) - struct dsc$descriptor *x; - SCM buff; -{(*x).dsc$w_length = LENGTH(buff); - (*x).dsc$a_pointer = CHARS(buff); - (*x).dsc$b_class = DSC$K_CLASS_S; - (*x).dsc$b_dtype = DSC$K_DTYPE_T; - return(x);} - -static char s_dynl[] = "vms:dynamic-link-call"; -SCM dynl(dir, symbol, fname) - SCM dir, symbol, fname; -{ - struct dsc$descriptor fnamed, symbold, dird; - void (*fcn)(); - long retval; - ASSERT(IMP(dir) || STRINGP(dir), dir, ARG1, s_dynl); - ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG2, s_dynl); - ASSERT(NIMP(symbol) && STRINGP(symbol), symbol, ARG3, s_dynl); - descriptorize(&fnamed, fname); - descriptorize(&symbold, symbol); - DEFER_INTS; - retval = lib$find_image_symbol(&fnamed, &symbold, &fcn, - IMP(dir) ? 0 : descriptorize(&dird, dir)); - if (SS$_NORMAL != retval) { - /* wta(MAKINUM(retval), "vms error", s_dynl); */ - ALLOW_INTS; - return BOOL_F; - } - ALLOW_INTS; -/* *loc_loadpath = dir; */ - (*fcn)(); -/* *loc_loadpath = oloadpath; */ - return BOOL_T; -} - -void init_dynl() -{ - make_subr(s_dynl, tc7_subr_3, dynl); -} diff --git a/libguile/dynl.c b/libguile/dynl.c deleted file mode 100644 index 800de3d7b..000000000 --- a/libguile/dynl.c +++ /dev/null @@ -1,147 +0,0 @@ -/* dynl.c - dynamic linking - * - * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* "dynl.c" dynamically link&load object files. - Author: Aubrey Jaffer - Modified for libguile by Marius Vollmer */ - -#include "_scm.h" - -/* Converting a list of SCM strings into a argv-style array. You must - have ints disabled for the whole lifetime of the created argv (from - before MAKE_ARGV_FROM_STRINGLIST until after - MUST_FREE_ARGV). Atleast this is was the documentation for - MAKARGVFROMSTRS says, it isn't really used that way. - - This code probably belongs into strings.c */ - -static char **scm_make_argv_from_stringlist SCM_P ((SCM args, int *argcp, - char *subr, int argn)); - -static char ** -scm_make_argv_from_stringlist (args, argcp, subr, argn) - SCM args; - int *argcp; - char *subr; - int argn; -{ - char **argv; - int argc, i; - - argc = scm_ilength(args); - argv = (char **) scm_must_malloc ((1L+argc)*sizeof(char *), subr); - for(i = 0; SCM_NNULLP (args); args = SCM_CDR (args), i++) { - size_t len; - char *dst, *src; - SCM str = SCM_CAR (args); - - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, argn, subr); - len = 1 + SCM_ROLENGTH (str); - dst = (char *) scm_must_malloc ((long)len, subr); - src = SCM_ROCHARS (str); - while (len--) - dst[len] = src[len]; - argv[i] = dst; - } - - if (argcp) - *argcp = argc; - argv[argc] = 0; - return argv; -} - -static void scm_must_free_argv SCM_P ((char **argv)); - -static void -scm_must_free_argv(argv) - char **argv; -{ - char **av = argv; - while(!(*av)) - free(*(av++)); - free(argv); -} - -/* Coerce an arbitrary readonly-string into a zero-terminated string. - */ - -static SCM scm_coerce_rostring SCM_P ((SCM rostr, char *subr, int argn)); - -static SCM -scm_coerce_rostring (rostr, subr, argn) - SCM rostr; - char *subr; - int argn; -{ - SCM_ASSERT (SCM_NIMP (rostr) && SCM_ROSTRINGP (rostr), rostr, argn, subr); - if (SCM_SUBSTRP (rostr)) - rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_ROLENGTH (rostr), 0); - return rostr; -} - -/* Dispatch to the system dependent files - */ - -#ifdef DYNAMIC_LINKING -#ifdef HAVE_LIBDL -#include "dynl-dl.c" -#else -#ifdef HAVE_SHL_LOAD -#include "dynl-shl.c" -#else -#ifdef HAVE_DLD -#include "dynl-dld.c" -#else /* no dynamic linking available */ -void -scm_init_dynamic_linking () -{ -} -#endif -#endif -#endif -#else /* dynamic linking disabled */ -void -scm_init_dynamic_linking () -{ -} -#endif diff --git a/libguile/dynl.h b/libguile/dynl.h deleted file mode 100644 index 723d2e950..000000000 --- a/libguile/dynl.h +++ /dev/null @@ -1,57 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#ifndef LIBGUILE_DYNL_H -#define LIBGUILE_DYNL_H - -#include "libguile/__scm.h" - - - -SCM scm_dynamic_link SCM_P ((SCM fname)); -SCM scm_dynamic_call SCM_P ((SCM symb, SCM shl)); -SCM scm_dynamic_args_call SCM_P ((SCM symb, SCM shl, SCM args)); -SCM scm_dynamic_unlink SCM_P ((SCM shl)); - -void scm_init_dynamic_linking SCM_P ((void)); - -#endif /* LIBGUILE_DYNL_H */ diff --git a/libguile/dynwind.c b/libguile/dynwind.c deleted file mode 100644 index 4a9424b0f..000000000 --- a/libguile/dynwind.c +++ /dev/null @@ -1,139 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "eval.h" -#include "alist.h" - -#include "dynwind.h" - - -/* {Dynamic wind} - */ - - - -SCM_PROC(s_dynamic_wind, "dynamic-wind", 3, 0, 0, scm_dynamic_wind); - -SCM -scm_dynamic_wind (thunk1, thunk2, thunk3) - SCM thunk1; - SCM thunk2; - SCM thunk3; -{ - SCM ans; - scm_apply (thunk1, SCM_EOL, SCM_EOL); - scm_dynwinds = scm_acons (thunk1, thunk3, scm_dynwinds); - ans = scm_apply (thunk2, SCM_EOL, SCM_EOL); - scm_dynwinds = SCM_CDR (scm_dynwinds); - scm_apply (thunk3, SCM_EOL, SCM_EOL); - return ans; -} - - -void -scm_dowinds (to, delta) - SCM to; - long delta; -{ - tail: - if (scm_dynwinds == to); - else if (0 > delta) - { - SCM wind_elt; - SCM wind_key; - - scm_dowinds (SCM_CDR (to), 1 + delta); - wind_elt = SCM_CAR (to); -#if 0 - if (SCM_INUMP (wind_elt)) - { - scm_cross_dynwind_binding_scope (wind_elt, 0); - } - else -#endif - { - wind_key = SCM_CAR (wind_elt); - if ( !(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key)) - && (wind_key != SCM_BOOL_F) - && (wind_key != SCM_BOOL_T)) - scm_apply (wind_key, SCM_EOL, SCM_EOL); - } - scm_dynwinds = to; - } - else - { - SCM from; - SCM wind_elt; - SCM wind_key; - - from = SCM_CDR (SCM_CAR (scm_dynwinds)); - wind_elt = SCM_CAR (scm_dynwinds); - scm_dynwinds = SCM_CDR (scm_dynwinds); -#if 0 - if (SCM_INUMP (wind_elt)) - { - scm_cross_dynwind_binding_scope (wind_elt, 0); - } - else -#endif - { - wind_key = SCM_CAR (wind_elt); - if ( !(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key)) - && (wind_key != SCM_BOOL_F) - && (wind_key != SCM_BOOL_T)) - scm_apply (from, SCM_EOL, SCM_EOL); - } - delta--; - goto tail; /* scm_dowinds(to, delta-1); */ - } -} - - - -void -scm_init_dynwind () -{ -#include "dynwind.x" -} - diff --git a/libguile/dynwind.h b/libguile/dynwind.h deleted file mode 100644 index 7352751c0..000000000 --- a/libguile/dynwind.h +++ /dev/null @@ -1,54 +0,0 @@ -/* classes: h_files */ - -#ifndef DYNWINDH -#define DYNWINDH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -extern SCM scm_dynamic_wind SCM_P ((SCM thunk1, SCM thunk2, SCM thunk3)); -extern void scm_dowinds SCM_P ((SCM to, long delta)); -extern void scm_init_dynwind SCM_P ((void)); - -#endif /* DYNWINDH */ diff --git a/libguile/eq.c b/libguile/eq.c deleted file mode 100644 index 5bc88fe75..000000000 --- a/libguile/eq.c +++ /dev/null @@ -1,152 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "ramap.h" -#include "stackchk.h" -#include "strorder.h" -#include "smob.h" -#include "unif.h" - -#include "eq.h" - -SCM_PROC1 (s_eq_p, "eq?", scm_tc7_rpsubr, scm_eq_p); - -SCM -scm_eq_p (x, y) - SCM x; - SCM y; -{ - return ((x==y) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC1 (s_eqv_p, "eqv?", scm_tc7_rpsubr, scm_eqv_p); - -SCM -scm_eqv_p (x, y) - SCM x; - SCM y; -{ - if (x==y) return SCM_BOOL_T; - if SCM_IMP(x) return SCM_BOOL_F; - if SCM_IMP(y) return SCM_BOOL_F; - /* this ensures that types and scm_length are the same. */ - if (SCM_CAR(x) != SCM_CAR(y)) return SCM_BOOL_F; - if SCM_NUMP(x) { -# ifdef SCM_BIGDIG - if SCM_BIGP(x) return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F; -# endif -#ifdef SCM_FLOATS - if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F; - if (SCM_CPLXP(x) && (SCM_IMAG(x) != SCM_IMAG(y))) return SCM_BOOL_F; -#endif - return SCM_BOOL_T; - } - return SCM_BOOL_F; -} - - -SCM_PROC1 (s_equal_p, "equal?", scm_tc7_rpsubr, scm_equal_p); - -SCM -scm_equal_p (x, y) - SCM x; - SCM y; -{ - SCM_CHECK_STACK; - tailrecurse: SCM_ASYNC_TICK; - if (x==y) return SCM_BOOL_T; - if (SCM_IMP(x)) return SCM_BOOL_F; - if (SCM_IMP(y)) return SCM_BOOL_F; - if (SCM_CONSP(x) && SCM_CONSP(y)) { - if SCM_FALSEP(scm_equal_p(SCM_CAR(x), SCM_CAR(y))) return SCM_BOOL_F; - x = SCM_CDR(x); - y = SCM_CDR(y); - goto tailrecurse; - } - /* this ensures that types and scm_length are the same. */ - if (SCM_CAR(x) != SCM_CAR(y)) return SCM_BOOL_F; - switch (SCM_TYP7(x)) { - default: return SCM_BOOL_F; - case scm_tc7_substring: - case scm_tc7_mb_substring: - case scm_tc7_mb_string: - case scm_tc7_string: return scm_string_equal_p(x, y); - case scm_tc7_vector: - case scm_tc7_wvect: - return scm_vector_equal_p(x, y); - case scm_tc7_smob: { - int i = SCM_SMOBNUM(x); - if (!(i < scm_numsmob)) return SCM_BOOL_F; - if (scm_smobs[i].equalp) - return (scm_smobs[i].equalp)(x, y); - else - return SCM_BOOL_F; - } - case scm_tc7_bvect: case scm_tc7_uvect: case scm_tc7_ivect: - case scm_tc7_fvect: case scm_tc7_cvect: case scm_tc7_dvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - case scm_tc7_byvect: - if ( scm_tc16_array - && scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp) - return scm_array_equal_p(x, y); - } - return SCM_BOOL_F; -} - - - - - - -void -scm_init_eq () -{ -#include "eq.x" -} - diff --git a/libguile/eq.h b/libguile/eq.h deleted file mode 100644 index c9deb5007..000000000 --- a/libguile/eq.h +++ /dev/null @@ -1,55 +0,0 @@ -/* classes: h_files */ - -#ifndef EQH -#define EQH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -extern SCM scm_eq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_eqv_p SCM_P ((SCM x, SCM y)); -extern SCM scm_equal_p SCM_P ((SCM x, SCM y)); -extern void scm_init_eq SCM_P ((void)); - -#endif /* EQH */ diff --git a/libguile/error.c b/libguile/error.c deleted file mode 100644 index 68f24a985..000000000 --- a/libguile/error.c +++ /dev/null @@ -1,328 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "pairs.h" -#include "genio.h" -#include "throw.h" - -#include "error.h" - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - - -/* {Errors and Exceptional Conditions} - */ - - -/* True between SCM_DEFER_INTS and SCM_ALLOW_INTS, and - * when the interpreter is not running at all. - */ -int scm_ints_disabled = 1; - -extern int errno; - -static void err_head SCM_P ((char *str)); - -static void -err_head (str) - char *str; -{ - int oerrno = errno; - if (SCM_NIMP (scm_cur_outp)) - scm_fflush (scm_cur_outp); - scm_gen_putc ('\n', scm_cur_errp); -#if 0 - if (SCM_BOOL_F != *scm_loc_loadpath) - { - scm_prin1 (*scm_loc_loadpath, scm_cur_errp, 1); - scm_gen_puts (scm_regular_string, ", line ", scm_cur_errp); - scm_intprint ((long) scm_linum, 10, scm_cur_errp); - scm_gen_puts (scm_regular_string, ": ", scm_cur_errp); - } -#endif - scm_fflush (scm_cur_errp); - errno = oerrno; - if (scm_cur_errp == scm_def_errp) - { - if (errno > 0) - perror (str); - fflush (stderr); - return; - } -} - - -SCM_PROC(s_errno, "errno", 0, 1, 0, scm_errno); -SCM -scm_errno (arg) - SCM arg; -{ - int old = errno; - if (!SCM_UNBNDP (arg)) - { - if (SCM_FALSEP (arg)) - errno = 0; - else - errno = SCM_INUM (arg); - } - return SCM_MAKINUM (old); -} - -SCM_PROC(s_perror, "perror", 1, 0, 0, scm_perror); -SCM -scm_perror (arg) - SCM arg; -{ - SCM_ASSERT (SCM_NIMP (arg) && SCM_STRINGP (arg), arg, SCM_ARG1, s_perror); - err_head (SCM_CHARS (arg)); - return SCM_UNSPECIFIED; -} - -void (*scm_error_callback) () = 0; - -/* all errors thrown from C should pass through here. */ -void -scm_error (key, subr, message, args, rest) - SCM key; - char *subr; - char *message; - SCM args; - SCM rest; -{ - SCM arg_list; - if (scm_error_callback) - (*scm_error_callback) (key, subr, message, args, rest); - - arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F, - message ? scm_makfrom0str (message) : SCM_BOOL_F, - args, - rest, - SCM_UNDEFINED); - scm_ithrow (key, arg_list, 1); - - /* No return, but just in case: */ - - write (2, "unhandled system error", sizeof ("unhandled system error") - 1); - exit (1); -} - -SCM_SYMBOL (scm_system_error_key, "system-error"); -void -scm_syserror (subr) - char *subr; -{ - scm_error (scm_system_error_key, - subr, - "%s", - scm_listify (scm_makfrom0str (strerror (errno)), - SCM_UNDEFINED), - scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED)); -} - -void -scm_syserror_msg (subr, message, args) - char *subr; - char *message; - SCM args; -{ - scm_error (scm_system_error_key, - subr, - message, - args, - scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED)); -} - -void -scm_sysmissing (subr) - char *subr; -{ -#ifdef ENOSYS - scm_error (scm_system_error_key, - subr, - "%s", - scm_listify (scm_makfrom0str (strerror (ENOSYS)), SCM_UNDEFINED), - scm_listify (SCM_MAKINUM (ENOSYS), SCM_UNDEFINED)); -#else - scm_error (scm_system_error_key, - subr, - "Missing function", - SCM_BOOL_F, - scm_listify (SCM_MAKINUM (0), SCM_UNDEFINED)); -#endif -} - -SCM_SYMBOL (scm_num_overflow_key, "numerical-overflow"); -void -scm_num_overflow (subr) - char *subr; -{ - scm_error (scm_num_overflow_key, - subr, - "Numerical overflow", - SCM_BOOL_F, - SCM_BOOL_F); -} - -SCM_SYMBOL (scm_out_of_range_key, "out-of-range"); -void -scm_out_of_range (subr, bad_value) - char *subr; - SCM bad_value; -{ - scm_error (scm_out_of_range_key, - subr, - "Argument out of range: %S", - scm_listify (bad_value, SCM_UNDEFINED), - SCM_BOOL_F); -} - -SCM_SYMBOL (scm_args_number_key, "wrong-number-of-args"); -void -scm_wrong_num_args (proc) - SCM proc; -{ - scm_error (scm_args_number_key, - NULL, - "Wrong number of arguments to %s", - scm_listify (proc, SCM_UNDEFINED), - SCM_BOOL_F); -} - -SCM_SYMBOL (scm_arg_type_key, "wrong-type-arg"); -void -scm_wrong_type_arg (subr, pos, bad_value) - char *subr; - int pos; - SCM bad_value; -{ - scm_error (scm_arg_type_key, - subr, - (pos == 0) ? "Wrong type argument: %S" - : "Wrong type argument in position %s: %S", - (pos == 0) ? scm_listify (bad_value, SCM_UNDEFINED) - : scm_listify (SCM_MAKINUM (pos), bad_value, SCM_UNDEFINED), - SCM_BOOL_F); -} - -SCM_SYMBOL (scm_memory_alloc_key, "memory-allocation-error"); -void -scm_memory_error (subr) - char *subr; -{ - scm_error (scm_memory_alloc_key, - subr, - "Memory allocation error", - SCM_BOOL_F, - SCM_BOOL_F); -} - -SCM_SYMBOL (scm_misc_error_key, "misc-error"); -void -scm_misc_error (subr, message, args) - char *subr; - char *message; - SCM args; -{ - scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F); -} - -/* implements the SCM_ASSERT interface. */ -SCM -scm_wta (arg, pos, s_subr) - SCM arg; - char *pos; - char *s_subr; -{ - if (!s_subr || !*s_subr) - s_subr = NULL; - if ((~0x1fL) & (long) pos) - { - /* error string supplied. */ - scm_misc_error (s_subr, pos, SCM_BOOL_F); - } - else - { - /* numerical error code. */ - int error = (long) pos; - - switch (error) - { - case SCM_ARGn: - scm_wrong_type_arg (s_subr, 0, arg); - case SCM_ARG1: - scm_wrong_type_arg (s_subr, 1, arg); - case SCM_ARG2: - scm_wrong_type_arg (s_subr, 2, arg); - case SCM_ARG3: - scm_wrong_type_arg (s_subr, 3, arg); - case SCM_ARG4: - scm_wrong_type_arg (s_subr, 4, arg); - case SCM_ARG5: - scm_wrong_type_arg (s_subr, 5, arg); - case SCM_WNA: - scm_wrong_num_args (arg); - case SCM_OUTOFRANGE: - scm_out_of_range (s_subr, arg); - case SCM_NALLOC: - scm_memory_error (s_subr); - default: - /* this shouldn't happen. */ - scm_misc_error (s_subr, "Unknown error", SCM_BOOL_F); - } - } - return SCM_UNSPECIFIED; -} - -/* obsolete interface: scm_everr (exp, env, arg, pos, s_subr) - was equivalent to scm_wta (arg, pos, s_subr) */ - -void -scm_init_error () -{ -#include "error.x" -} - diff --git a/libguile/error.h b/libguile/error.h deleted file mode 100644 index 0ce16289a..000000000 --- a/libguile/error.h +++ /dev/null @@ -1,84 +0,0 @@ -/* classes: h_files */ - -#ifndef ERRORH -#define ERRORH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - -extern int scm_ints_disabled; - - - -/* GCC can be told that a function doesn't return; this helps it do - better error checking (for uninitialized variable use, for - example), and some optimization. */ -#ifdef __GNUC__ -#define SCM_NORETURN __attribute__ ((noreturn)) -#else -#define SCM_NORETURN -#endif - - -extern SCM scm_errno SCM_P ((SCM arg)); -extern SCM scm_perror SCM_P ((SCM arg)); -extern void scm_error SCM_P ((SCM key, char *subr, char *message, - SCM args, SCM rest)) SCM_NORETURN; -extern void (*scm_error_callback) SCM_P ((SCM key, char *subr, - char *message, SCM args, SCM rest)); -extern void scm_syserror SCM_P ((char *subr)) SCM_NORETURN; -extern void scm_syserror_msg SCM_P ((char *subr, char *message, SCM args)) - SCM_NORETURN; -extern void scm_sysmissing SCM_P ((char *subr)) SCM_NORETURN; -extern void scm_num_overflow SCM_P ((char *subr)) SCM_NORETURN; -extern void scm_out_of_range SCM_P ((char *subr, SCM bad_value)) SCM_NORETURN; -extern void scm_wrong_num_args SCM_P ((SCM proc)) SCM_NORETURN; -extern void scm_wrong_type_arg SCM_P ((char *subr, int pos, SCM bad_value)) - SCM_NORETURN; -extern void scm_memory_error SCM_P ((char *subr)) SCM_NORETURN; -extern void scm_misc_error SCM_P ((char *subr, char *message, SCM args)) - SCM_NORETURN; -extern SCM scm_wta SCM_P ((SCM arg, char *pos, char *s_subr)); -extern void scm_init_error SCM_P ((void)); - -#endif /* ERRORH */ diff --git a/libguile/eval.h b/libguile/eval.h deleted file mode 100644 index f83eb1560..000000000 --- a/libguile/eval.h +++ /dev/null @@ -1,170 +0,0 @@ -/* classes: h_files */ - -#ifndef EVALH -#define EVALH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -/* {Ilocs} - * - * Ilocs are relative pointers into local environment structures. - * - */ -#define SCM_ILOCP(n) (SCM_ITAG8(n)==scm_tc8_iloc) -#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc) -#define SCM_IDINC (0x00100000L) -#define SCM_ICDR (0x00080000L) -#define SCM_IFRINC (0x00000100L) -#define SCM_IDSTMSK (-SCM_IDINC) -#define SCM_IFRAME(n) ((int)((SCM_ICDR-SCM_IFRINC)>>8) & ((int)(n)>>8)) -#define SCM_IDIST(n) (((unsigned long)(n))>>20) -#define SCM_ICDRP(n) (SCM_ICDR & (n)) - - - - -/* {Evaluator} - * - * For an explanation of symbols containing "EVAL", see beginning of eval.c. - */ -#ifdef DEBUG_EXTENSIONS -#define XEVAL(x, env) (SCM_IMP(x) \ - ? (x) \ - : (*scm_ceval_ptr) ((x), (env))) -#else -#define XEVAL(x, env) (SCM_IMP(x)?(x):scm_ceval((x), (env))) -#endif /* DEBUG_EXTENSIONS */ - -#define SCM_CEVAL scm_ceval -#define SIDEVAL(x, env) if SCM_NIMP(x) SCM_CEVAL((x), (env)) - - - -#define SCM_EXTEND_ENV scm_acons - - -extern SCM scm_i_dot; -extern SCM scm_i_quote; -extern SCM scm_i_quasiquote; -extern SCM scm_i_lambda; -extern SCM scm_i_let; -extern SCM scm_i_arrow; -extern SCM scm_i_else; -extern SCM scm_i_unquote; -extern SCM scm_i_uq_splicing; -extern SCM scm_i_apply; - - -/* A resolved global variable reference in the CAR position - * of a list is stored (in code only) as a pointer to a pair with a - * tag of 1. This is called a "gloc". - */ - -#define SCM_GLOC_SYM(x) (SCM_CAR((x)-1L)) -#define SCM_GLOC_VAL(x) (SCM_CDR((x)-1L)) -#define SCM_GLOC_VAL_LOC(x) (SCM_CDRLOC((x)-1L)) - - - -extern SCM * scm_ilookup SCM_P ((SCM iloc, SCM env)); -extern SCM * scm_lookupcar SCM_P ((SCM vloc, SCM genv)); -extern SCM scm_unmemocar SCM_P ((SCM form, SCM env)); -extern SCM scm_unmemocopy SCM_P ((SCM form, SCM env)); -extern SCM scm_eval_car SCM_P ((SCM pair, SCM env)); -extern SCM scm_eval_args SCM_P ((SCM i, SCM env)); -extern SCM scm_deval_args SCM_P ((SCM l, SCM env, SCM *lloc)); -extern SCM scm_m_quote SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_begin SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_if SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_set SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_vref SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_vset SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_and SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_or SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_case SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_cond SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_lambda SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_letstar SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_do SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_quasiquote SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_delay SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_define SCM_P ((SCM x, SCM env)); -extern SCM scm_m_letrec SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_let SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_apply SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_cont SCM_P ((SCM xorig, SCM env)); -extern SCM scm_m_undefine SCM_P ((SCM x, SCM env)); -extern int scm_badargsp SCM_P ((SCM formals, SCM args)); -extern SCM scm_ceval SCM_P ((SCM x, SCM env)); -extern SCM scm_deval SCM_P ((SCM x, SCM env)); -extern SCM scm_procedure_documentation SCM_P ((SCM proc)); -extern SCM scm_nconc2last SCM_P ((SCM lst)); -extern SCM scm_apply SCM_P ((SCM proc, SCM arg1, SCM args)); -extern SCM scm_dapply SCM_P ((SCM proc, SCM arg1, SCM args)); -extern SCM SCM_APPLY SCM_P ((SCM proc, SCM arg1, SCM args)); -extern SCM scm_map SCM_P ((SCM proc, SCM arg1, SCM args)); -extern SCM scm_for_each SCM_P ((SCM proc, SCM arg1, SCM args)); -extern SCM scm_closure SCM_P ((SCM code, SCM env)); -extern SCM scm_makprom SCM_P ((SCM code)); -extern SCM scm_makacro SCM_P ((SCM code)); -extern SCM scm_makmacro SCM_P ((SCM code)); -extern SCM scm_makmmacro SCM_P ((SCM code)); -extern SCM scm_force SCM_P ((SCM x)); -extern SCM scm_promise_p SCM_P ((SCM x)); -extern SCM scm_copy_tree SCM_P ((SCM obj)); -extern SCM scm_eval_3 SCM_P ((SCM obj, int copyp, SCM env)); -extern SCM scm_top_level_env SCM_P ((SCM thunk)); -extern SCM scm_eval2 SCM_P ((SCM obj, SCM env_thunk)); -extern SCM scm_eval SCM_P ((SCM obj)); -extern SCM scm_eval_x SCM_P ((SCM obj)); -extern SCM scm_macro_eval_x SCM_P ((SCM exp, SCM env)); -extern SCM scm_definedp SCM_P ((SCM sym)); -extern SCM scm_make_synt SCM_P ((char *name, - SCM (*macroizer) (SCM), - SCM (*fcn) ())); -extern void scm_init_eval SCM_P ((void)); - -#endif /* EVALH */ diff --git a/libguile/extchrs.c b/libguile/extchrs.c deleted file mode 100644 index 6b063da8a..000000000 --- a/libguile/extchrs.c +++ /dev/null @@ -1,134 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "extchrs.h" - - - -#ifdef SCM_FAKE_EXT_CHARS - - -int -xmblen (str, size) - const char * str; - size_t size; -{ - if (!str) - return 0; - - if (*(unsigned char *)str > 127) - return ((size < 4) - ? -1 - : 4); - else if (!*str) - return 0; - else - return 1; -} - - -int -xwctomb (_str, c) - char * _str; - int c; -{ - unsigned char * str; - str = (unsigned char *)_str; - if (!str) - return 0; - - if (!c) - { - *str = 0; - return 0; - } - - - if (c < 127) - { - *str = c; - return 1; - } - - str[0] = 255; - str[1] = 0x80 | ((c >> 10) & 0x3f); - str[2] = 0x80 | ((c >> 4) & 0x3f); - str[3] = 0x80 | (c & 0xf); - return 4; -} - - -int -xmbtowc (result, _str, size) - xwchar_t * result; - const unsigned char * _str; - size_t size; -{ - const unsigned char * str; - str = (const unsigned char *)_str; - if (!str) - return 0; - - if ((size == 0) || !*str) - { - *result = 0; - return 0; - } - - if (*str < 128) - { - *result = *str; - return 1; - } - - if ( (*str != 255) - || (size < 4)) - return -1; - - *result = ( ((str[1] & 0x3f) << 10) - | ((str[2] & 0x3f) << 4) - | (str[3] & 0xf)); - return 4; -} - -#endif /* SCM_FAKE_EXT_CHARS */ - diff --git a/libguile/extchrs.h b/libguile/extchrs.h deleted file mode 100644 index 3f1f02276..000000000 --- a/libguile/extchrs.h +++ /dev/null @@ -1,74 +0,0 @@ -/* classes: h_files */ - -#ifndef EXTCHRSH -#define EXTCHRSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdlib.h> - -#include "libguile/__scm.h" - -#define SCM_FAKE_EXT_CHARS 1 - -#if !defined(SCM_FAKE_EXT_CHARS) - -#define xmblen mblen -#define xwctomb wctomb -#define xmbtowc mbtowc -#define XMB_CUR_MAX MB_CUR_MAX -typedef wchar_t xwchar_t; - -#else - -typedef unsigned short xwchar_t; -#define XMB_CUR_MAX 4 - -#endif - - - -extern int xmblen SCM_P ((const char * str, size_t size)); -extern int xwctomb SCM_P ((char * _str, int c)); -extern int xmbtowc SCM_P ((xwchar_t * result, const unsigned char * _str, size_t size)); - -#endif /* EXTCHRSH */ diff --git a/libguile/feature.c b/libguile/feature.c deleted file mode 100644 index 9aaee678c..000000000 --- a/libguile/feature.c +++ /dev/null @@ -1,121 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "feature.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - -static SCM *scm_loc_features; - -void -scm_add_feature(str) - char* str; -{ - *scm_loc_features = scm_cons(SCM_CAR(scm_intern(str, strlen(str))), - *scm_loc_features); -} - - - -SCM_PROC(s_program_arguments, "program-arguments", 0, 0, 0, scm_program_arguments); - -SCM -scm_program_arguments () -{ - return scm_progargs; -} - -/* Set the value returned by program-arguments, given ARGC and ARGV. - - If FIRST is non-zero, make it the first element; we do this in - situations where other code (like getopt) has parsed out a few - arguments, but we still want the script name to be the first - element. */ -void -scm_set_program_arguments (argc, argv, first) - int argc; - char **argv; - char *first; -{ - scm_progargs = scm_makfromstrs (argc, argv); - if (first) - scm_progargs = scm_cons (scm_makfrom0str (first), scm_progargs); -} - - - - -void -scm_init_feature() -{ - scm_loc_features = SCM_CDRLOC (scm_sysintern ("*features*", SCM_EOL)); -#ifdef RECKLESS - scm_add_feature("reckless"); -#endif -#ifndef _Windows - scm_add_feature("system"); -#endif -#ifdef vms - scm_add_feature(s_ed); -#endif -#ifdef SICP - scm_add_feature("sicp"); -#endif -#ifndef GO32 - scm_add_feature("char-ready?"); -#endif -#ifndef CHEAP_CONTINUATIONS - scm_add_feature ("full-continuation"); -#endif -#ifdef USE_THREADS - scm_add_feature ("threads"); -#endif - - scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT)); -#include "feature.x" -} diff --git a/libguile/feature.h b/libguile/feature.h deleted file mode 100644 index 712aff8a0..000000000 --- a/libguile/feature.h +++ /dev/null @@ -1,55 +0,0 @@ -/* classes: h_files */ - -#ifndef FEATUREH -#define FEATUREH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -extern void scm_add_feature SCM_P((char* str)); -extern SCM scm_program_arguments SCM_P((void)); -extern void scm_set_program_arguments SCM_P ((int argc, char **argv, - char *first)); -extern void scm_init_feature SCM_P((void)); - -#endif /* FEATUREH */ diff --git a/libguile/filesys.c b/libguile/filesys.c deleted file mode 100644 index 38f0b7768..000000000 --- a/libguile/filesys.c +++ /dev/null @@ -1,1311 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "_scm.h" -#include "genio.h" -#include "smob.h" -#include "feature.h" - -#include "filesys.h" - -#ifdef TIME_WITH_SYS_TIME -# include <sys/time.h> -# include <time.h> -#else -# if HAVE_SYS_TIME_H -# include <sys/time.h> -# else -# include <time.h> -# endif -#endif - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - -#ifdef LIBC_H_WITH_UNISTD_H -#include <libc.h> -#endif - -#ifdef HAVE_SYS_SELECT_H -#include <sys/select.h> -#endif - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - -#include <sys/types.h> -#include <sys/stat.h> -#include <fcntl.h> - -#include <pwd.h> - - -#ifdef FD_SET - -#define SELECT_TYPE fd_set -#define SELECT_SET_SIZE FD_SETSIZE - -#else /* no FD_SET */ - -/* Define the macros to access a single-int bitmap of descriptors. */ -#define SELECT_SET_SIZE 32 -#define SELECT_TYPE int -#define FD_SET(n, p) (*(p) |= (1 << (n))) -#define FD_CLR(n, p) (*(p) &= ~(1 << (n))) -#define FD_ISSET(n, p) (*(p) & (1 << (n))) -#define FD_ZERO(p) (*(p) = 0) - -#endif /* no FD_SET */ - -#if HAVE_DIRENT_H -# include <dirent.h> -# define NAMLEN(dirent) strlen((dirent)->d_name) -#else -# define dirent direct -# define NAMLEN(dirent) (dirent)->d_namlen -# if HAVE_SYS_NDIR_H -# include <sys/ndir.h> -# endif -# if HAVE_SYS_DIR_H -# include <sys/dir.h> -# endif -# if HAVE_NDIR_H -# include <ndir.h> -# endif -#endif - - - -#ifdef O_CREAT -SCM_CONST_LONG (scm_O_CREAT, "O_CREAT", O_CREAT); -#endif - -#ifdef O_EXCL -SCM_CONST_LONG (scm_O_EXCL, "O_EXCL", O_EXCL); -#endif - -#ifdef O_NOCTTY -SCM_CONST_LONG (scm_O_NOCTTY, "O_NOCTTY", O_NOCTTY); -#endif - -#ifdef O_TRUNC -SCM_CONST_LONG (scm_O_TRUNC, "O_TRUNC", O_TRUNC); -#endif - -#ifdef O_APPEND -SCM_CONST_LONG (scm_O_APPEND, "O_APPEND", O_APPEND); -#endif - -#ifdef O_NONBLOCK -SCM_CONST_LONG (scm_O_NONBLOCK, "O_NONBLOCK", O_NONBLOCK); -#endif - -#ifdef O_NDELAY -SCM_CONST_LONG (scm_O_NDELAY, "O_NDELAY", O_NDELAY); -#endif - -#ifdef O_SYNC -SCM_CONST_LONG (scm_O_SYNC, "O_SYNC", O_SYNC); -#endif - - - - - -/* {Permissions} - */ - -SCM_PROC (s_sys_chown, "chown", 3, 0, 0, scm_sys_chown); - -SCM -scm_sys_chown (path, owner, group) - SCM path; - SCM owner; - SCM group; -{ - int val; - - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_chown); - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - SCM_ASSERT (SCM_INUMP (owner), owner, SCM_ARG2, s_sys_chown); - SCM_ASSERT (SCM_INUMP (group), group, SCM_ARG3, s_sys_chown); - SCM_SYSCALL (val = chown (SCM_ROCHARS (path), - SCM_INUM (owner), SCM_INUM (group))); - if (val != 0) - scm_syserror (s_sys_chown); - return SCM_UNSPECIFIED; -} - - -SCM_PROC (s_sys_chmod, "chmod", 2, 0, 0, scm_sys_chmod); - -SCM -scm_sys_chmod (port_or_path, mode) - SCM port_or_path; - SCM mode; -{ - int rv; - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_chmod); - SCM_ASSERT (SCM_NIMP (port_or_path), port_or_path, SCM_ARG1, s_sys_chmod); - if (SCM_STRINGP (port_or_path)) - SCM_SYSCALL (rv = chmod (SCM_CHARS (port_or_path), SCM_INUM (mode))); - else - { - SCM_ASSERT (SCM_OPFPORTP (port_or_path), port_or_path, SCM_ARG1, s_sys_chmod); - rv = fileno ((FILE *)SCM_STREAM (port_or_path)); - if (rv != -1) - SCM_SYSCALL (rv = fchmod (rv, SCM_INUM (mode))); - } - if (rv != 0) - scm_syserror (s_sys_chmod); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_umask, "umask", 0, 1, 0, scm_umask); - -SCM -scm_umask (mode) - SCM mode; -{ - mode_t mask; - if (SCM_UNBNDP (mode)) - { - mask = umask (0); - umask (mask); - } - else - { - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG1, s_umask); - mask = umask (SCM_INUM (mode)); - } - return SCM_MAKINUM (mask); -} - - -/* {File Descriptors} - */ -long scm_tc16_fd; - - -static int scm_fd_print SCM_P ((SCM sexp, SCM port, scm_print_state *pstate)); - -static int -scm_fd_print (sexp, port, pstate) - SCM sexp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<fd ", port); - scm_intprint (SCM_CDR (sexp), 10, port); - scm_gen_puts (scm_regular_string, ">", port); - return 1; -} - - -static scm_sizet scm_fd_free SCM_P ((SCM p)); - -static scm_sizet -scm_fd_free (p) - SCM p; -{ - SCM flags; - - flags = SCM_FD_FLAGS (p); - if ((scm_close_fd_on_gc & flags) && (scm_fd_is_open & flags)) - { - SCM_SYSCALL( close (SCM_FD (p)) ); - } - return 0; -} - -static scm_smobfuns fd_smob = {scm_mark0, scm_fd_free, scm_fd_print, 0}; - - -SCM -scm_intern_fd (fd, flags) - int fd; - int flags; -{ - SCM it; - SCM_NEWCELL (it); - SCM_REDEFER_INTS; - SCM_SETCAR (it, (scm_tc16_fd | (flags << 16))); - SCM_SETCDR (it, (SCM)fd); - SCM_REALLOW_INTS; - return it; -} - - - -SCM_PROC (s_sys_open, "open", 3, 0, 0, scm_sys_open); - -SCM -scm_sys_open (path, flags, mode) - SCM path; - SCM flags; - SCM mode; -{ - int fd; - SCM sfd; - - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_open); - SCM_ASSERT (SCM_INUMP (flags), flags, SCM_ARG2, s_sys_open); - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG3, s_sys_open); - - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - - SCM_DEFER_INTS; - SCM_SYSCALL ( fd = open (SCM_ROCHARS (path), SCM_INUM (flags), SCM_INUM (mode)) ); - if (fd == -1) - scm_syserror (s_sys_open); - sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc); - SCM_ALLOW_INTS; - - return scm_return_first (sfd, path); -} - - -SCM_PROC (s_sys_create, "create", 2, 0, 0, scm_sys_create); - -SCM -scm_sys_create (path, mode) - SCM path; - SCM mode; -{ - int fd; - SCM sfd; - - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_create); - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_create); - - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - - SCM_DEFER_INTS; - SCM_SYSCALL ( fd = creat (SCM_ROCHARS (path), SCM_INUM (mode)) ); - if (fd == -1) - scm_syserror (s_sys_create); - sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc); - SCM_ALLOW_INTS; - - return scm_return_first (sfd, path); -} - - -SCM_PROC (s_sys_close, "close", 1, 0, 0, scm_sys_close); - -SCM -scm_sys_close (sfd) - SCM sfd; -{ - int fd; - int got; - SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_close); - fd = SCM_FD (sfd); - - SCM_DEFER_INTS; - got = close (fd); - SCM_SETCAR (sfd, scm_tc16_fd); - SCM_ALLOW_INTS; - if (got == -1) - scm_syserror (s_sys_close); - return SCM_UNSPECIFIED; -} - - -SCM_PROC (s_sys_write_fd, "write-fd", 2, 0, 0, scm_sys_write_fd); - -SCM -scm_sys_write_fd (sfd, buf) - SCM sfd; - SCM buf; -{ - SCM answer; - int fd; - size_t written; - SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_write_fd); - SCM_ASSERT (SCM_NIMP (buf) && SCM_ROSTRINGP (buf), buf, SCM_ARG2, s_sys_write_fd); - fd = SCM_FD (sfd); - SCM_DEFER_INTS; - written = write (fd, SCM_ROCHARS (buf), SCM_ROLENGTH (buf)); - if (written == -1) - scm_syserror (s_sys_write_fd); - answer = scm_long2num (written); - SCM_ALLOW_INTS; - return scm_return_first (answer, buf); -} - - -SCM_PROC (s_sys_read_fd, "read-fd", 2, 2, 0, scm_sys_read_fd); - -SCM -scm_sys_read_fd (sfd, buf, offset, length) - SCM sfd; - SCM buf; - SCM offset; - SCM length; -{ - SCM answer; - int fd; - char * bytes; - int off; - int len; - size_t got; - - SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_read_fd); - fd = SCM_FD (sfd); - - SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_sys_read_fd); - bytes = SCM_CHARS (buf); - - if (SCM_UNBNDP (offset)) - off = 0; - else - { - SCM_ASSERT (SCM_INUMP (offset), offset, SCM_ARG3, s_sys_read_fd); - off = SCM_INUM (offset); - } - - if (SCM_UNBNDP (length)) - len = SCM_LENGTH (buf); - else - { - SCM_ASSERT (SCM_INUMP (length), length, SCM_ARG3, s_sys_read_fd); - len = SCM_INUM (length); - } - - SCM_DEFER_INTS; - got = read (fd, bytes + off, len); - if (got == -1) - scm_syserror (s_sys_read_fd); - answer = scm_long2num (got); - SCM_ALLOW_INTS; - return scm_return_first (answer, buf); -} - -SCM_PROC (s_sys_lseek, "lseek", 2, 1, 0, scm_sys_lseek); - -SCM -scm_sys_lseek (sfd, offset, whence) - SCM sfd; - SCM offset; - SCM whence; -{ - SCM answer; - int fd; - long off; - int wh; - long got; - - SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_lseek); - fd = SCM_FD (sfd); - - off = scm_num2long (offset, (char *)SCM_ARG2, s_sys_lseek); - if (SCM_UNBNDP (whence)) - wh = SEEK_SET; - else - { - SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_sys_lseek); - wh = SCM_INUM (whence); - } - - SCM_DEFER_INTS; - SCM_SYSCALL (got = lseek (fd, off, wh)); - if (got == -1) - scm_syserror (s_sys_lseek); - answer = scm_long2num (got); - SCM_ALLOW_INTS; - return answer; -} - - -SCM_PROC (s_sys_dup, "dup", 1, 1, 0, scm_sys_dup); - -SCM -scm_sys_dup (oldfd, newfd) - SCM oldfd; - SCM newfd; -{ - SCM answer; - int fd; - int nfd; - int (*fn)(); - - SCM_ASSERT (SCM_NIMP (oldfd) && SCM_FD_P (oldfd), oldfd, SCM_ARG1, s_sys_dup); - SCM_ASSERT (SCM_UNBNDP (newfd) || SCM_INUMP (newfd), newfd, SCM_ARG2, s_sys_dup); - fd = SCM_FD (oldfd); - nfd = (SCM_INUMP (newfd) ? SCM_INUM (newfd) : -1); - - SCM_DEFER_INTS; - fn = ((nfd == -1) ? (int (*)())dup : (int (*)())dup2); - nfd = fn (fd, nfd); - if (nfd == -1) - scm_syserror (s_sys_dup); - answer = SCM_MAKINUM (nfd); - SCM_ALLOW_INTS; - return answer; -} - - - -/* {Files} - */ - -SCM_SYMBOL (scm_sym_regular, "regular"); -SCM_SYMBOL (scm_sym_directory, "directory"); -SCM_SYMBOL (scm_sym_symlink, "symlink"); -SCM_SYMBOL (scm_sym_block_special, "block-special"); -SCM_SYMBOL (scm_sym_char_special, "char-special"); -SCM_SYMBOL (scm_sym_fifo, "fifo"); -SCM_SYMBOL (scm_sym_sock, "socket"); -SCM_SYMBOL (scm_sym_unknown, "unknown"); - -static SCM scm_stat2scm SCM_P ((struct stat *stat_temp)); - -static SCM -scm_stat2scm (stat_temp) - struct stat *stat_temp; -{ - SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED, SCM_BOOL_F); - SCM *ve = SCM_VELTS (ans); - - ve[0] = scm_ulong2num ((unsigned long) stat_temp->st_dev); - ve[1] = scm_ulong2num ((unsigned long) stat_temp->st_ino); - ve[2] = scm_ulong2num ((unsigned long) stat_temp->st_mode); - ve[3] = scm_ulong2num ((unsigned long) stat_temp->st_nlink); - ve[4] = scm_ulong2num ((unsigned long) stat_temp->st_uid); - ve[5] = scm_ulong2num ((unsigned long) stat_temp->st_gid); -#ifdef HAVE_ST_RDEV - ve[6] = scm_ulong2num ((unsigned long) stat_temp->st_rdev); -#else - ve[6] = SCM_BOOL_F; -#endif - ve[7] = scm_ulong2num ((unsigned long) stat_temp->st_size); - ve[8] = scm_ulong2num ((unsigned long) stat_temp->st_atime); - ve[9] = scm_ulong2num ((unsigned long) stat_temp->st_mtime); - ve[10] = scm_ulong2num ((unsigned long) stat_temp->st_ctime); -#ifdef HAVE_ST_BLKSIZE - ve[11] = scm_ulong2num ((unsigned long) stat_temp->st_blksize); -#else - ve[11] = scm_ulong2num (4096L); -#endif -#ifdef HAVE_ST_BLOCKS - ve[12] = scm_ulong2num ((unsigned long) stat_temp->st_blocks); -#else - ve[12] = SCM_BOOL_F; -#endif - { - int mode = stat_temp->st_mode; - - if (S_ISREG (mode)) - ve[13] = scm_sym_regular; - else if (S_ISDIR (mode)) - ve[13] = scm_sym_directory; - else if (S_ISLNK (mode)) - ve[13] = scm_sym_symlink; - else if (S_ISBLK (mode)) - ve[13] = scm_sym_block_special; - else if (S_ISCHR (mode)) - ve[13] = scm_sym_char_special; - else if (S_ISFIFO (mode)) - ve[13] = scm_sym_fifo; - else if (S_ISSOCK (mode)) - ve[13] = scm_sym_sock; - else - ve[13] = scm_sym_unknown; - - ve[14] = SCM_MAKINUM ((~S_IFMT) & mode); - - /* the layout of the bits in ve[14] is intended to be portable. - If there are systems that don't follow the usual convention, - the following could be used: - - tmp = 0; - if (S_ISUID & mode) tmp += 1; - tmp <<= 1; - if (S_IRGRP & mode) tmp += 1; - tmp <<= 1; - if (S_ISVTX & mode) tmp += 1; - tmp <<= 1; - if (S_IRUSR & mode) tmp += 1; - tmp <<= 1; - if (S_IWUSR & mode) tmp += 1; - tmp <<= 1; - if (S_IXUSR & mode) tmp += 1; - tmp <<= 1; - if (S_IWGRP & mode) tmp += 1; - tmp <<= 1; - if (S_IXGRP & mode) tmp += 1; - tmp <<= 1; - if (S_IROTH & mode) tmp += 1; - tmp <<= 1; - if (S_IWOTH & mode) tmp += 1; - tmp <<= 1; - if (S_IXOTH & mode) tmp += 1; - - ve[14] = SCM_MAKINUM (tmp); - - */ - } - - return ans; -} - -SCM_PROC (s_sys_stat, "stat", 1, 0, 0, scm_sys_stat); - -SCM -scm_sys_stat (fd_or_path) - SCM fd_or_path; -{ - int rv = 1; - struct stat stat_temp; - - if (SCM_INUMP (fd_or_path)) - { - rv = SCM_INUM (fd_or_path); - SCM_SYSCALL (rv = fstat (rv, &stat_temp)); - } - else if (SCM_NIMP (fd_or_path) && SCM_FD_P (fd_or_path)) - { - rv = SCM_FD (fd_or_path); - SCM_SYSCALL (rv = fstat (rv, &stat_temp)); - } - else - { - SCM_ASSERT (SCM_NIMP (fd_or_path), fd_or_path, SCM_ARG1, s_sys_stat); - SCM_ASSERT (SCM_ROSTRINGP (fd_or_path), fd_or_path, SCM_ARG1, s_sys_stat); - if (SCM_ROSTRINGP (fd_or_path)) - { - if (SCM_SUBSTRP (fd_or_path)) - fd_or_path = scm_makfromstr (SCM_ROCHARS (fd_or_path), SCM_ROLENGTH (fd_or_path), 0); - SCM_SYSCALL (rv = stat (SCM_CHARS (fd_or_path), &stat_temp)); - } - - } - if (rv != 0) - scm_syserror_msg (s_sys_stat, "%s: %S", - scm_listify (scm_makfrom0str (strerror (errno)), - fd_or_path, - SCM_UNDEFINED)); - return scm_stat2scm (&stat_temp); -} - - - -/* {Modifying Directories} - */ - -SCM_PROC (s_sys_link, "link", 2, 0, 0, scm_sys_link); - -SCM -scm_sys_link (oldpath, newpath) - SCM oldpath; - SCM newpath; -{ - int val; - - SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1, s_sys_link); - if (SCM_SUBSTRP (oldpath)) - oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), SCM_ROLENGTH (oldpath), 0); - SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, SCM_ARG2, s_sys_link); - if (SCM_SUBSTRP (newpath)) - newpath = scm_makfromstr (SCM_ROCHARS (newpath), SCM_ROLENGTH (newpath), 0); - SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath))); - if (val != 0) - scm_syserror (s_sys_link); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_sys_rename, "rename-file", 2, 0, 0, scm_sys_rename); - -SCM -scm_sys_rename (oldname, newname) - SCM oldname; - SCM newname; -{ - int rv; - SCM_ASSERT (SCM_NIMP (oldname) && SCM_STRINGP (oldname), oldname, SCM_ARG1, s_sys_rename); - SCM_ASSERT (SCM_NIMP (newname) && SCM_STRINGP (newname), newname, SCM_ARG2, s_sys_rename); -#ifdef HAVE_RENAME - SCM_SYSCALL (rv = rename (SCM_CHARS (oldname), SCM_CHARS (newname))); - if (rv != 0) - scm_syserror (s_sys_rename); - return SCM_UNSPECIFIED; -#else - SCM_DEFER_INTS; - SCM_SYSCALL (rv = link (SCM_CHARS (oldname), SCM_CHARS (newname))); - if (rv == 0) - { - SCM_SYSCALL (rv = unlink (SCM_CHARS (oldname)));; - if (rv != 0) - /* unlink failed. remove new name */ - SCM_SYSCALL (unlink (SCM_CHARS (newname))); - } - SCM_ALLOW_INTS; - if (rv != 0) - scm_syserror (s_sys_rename); - return SCM_UNSPECIFIED; -#endif -} - - -SCM_PROC(s_sys_delete_file, "delete-file", 1, 0, 0, scm_sys_delete_file); - -SCM -scm_sys_delete_file (str) - SCM str; -{ - int ans; - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_delete_file); - SCM_SYSCALL (ans = unlink (SCM_CHARS (str))); - if (ans != 0) - scm_syserror (s_sys_delete_file); - return SCM_UNSPECIFIED; -} - - -SCM_PROC (s_sys_mkdir, "mkdir", 1, 1, 0, scm_sys_mkdir); - -SCM -scm_sys_mkdir (path, mode) - SCM path; - SCM mode; -{ -#ifdef HAVE_MKDIR - int rv; - mode_t mask; - SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_sys_mkdir); - if (SCM_UNBNDP (mode)) - { - mask = umask (0); - umask (mask); - SCM_SYSCALL (rv = mkdir (SCM_CHARS (path), 0777 ^ mask)); - } - else - { - SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_mkdir); - SCM_SYSCALL (rv = mkdir (SCM_CHARS (path), SCM_INUM (mode))); - } - if (rv != 0) - scm_syserror (s_sys_mkdir); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_sys_mkdir); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_sys_rmdir, "rmdir", 1, 0, 0, scm_sys_rmdir); - -SCM -scm_sys_rmdir (path) - SCM path; -{ -#ifdef HAVE_RMDIR - int val; - - SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_sys_rmdir); - SCM_SYSCALL (val = rmdir (SCM_CHARS (path))); - if (val != 0) - scm_syserror (s_sys_rmdir); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_sys_rmdir); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -/* {Examining Directories} - */ - -long scm_tc16_dir; - -SCM_PROC (s_sys_opendir, "opendir", 1, 0, 0, scm_sys_opendir); - -SCM -scm_sys_opendir (dirname) - SCM dirname; -{ - DIR *ds; - SCM dir; - SCM_ASSERT (SCM_NIMP (dirname) && SCM_STRINGP (dirname), dirname, SCM_ARG1, s_sys_opendir); - SCM_NEWCELL (dir); - SCM_DEFER_INTS; - SCM_SYSCALL (ds = opendir (SCM_CHARS (dirname))); - if (ds == NULL) - scm_syserror (s_sys_opendir); - SCM_SETCAR (dir, scm_tc16_dir | SCM_OPN); - SCM_SETCDR (dir, ds); - SCM_ALLOW_INTS; - return dir; -} - - -SCM_PROC (s_sys_readdir, "readdir", 1, 0, 0, scm_sys_readdir); - -SCM -scm_sys_readdir (port) - SCM port; -{ - struct dirent *rdent; - SCM_DEFER_INTS; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_sys_readdir); - errno = 0; - SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port))); - SCM_ALLOW_INTS; - if (errno != 0) - scm_syserror (s_sys_readdir); - return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0) - : SCM_EOF_VAL); -} - - - -SCM_PROC (s_rewinddir, "rewinddir", 1, 0, 0, scm_rewinddir); - -SCM -scm_rewinddir (port) - SCM port; -{ - SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_rewinddir); - rewinddir ((DIR *) SCM_CDR (port)); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_sys_closedir, "closedir", 1, 0, 0, scm_sys_closedir); - -SCM -scm_sys_closedir (port) - SCM port; -{ - int sts; - - SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, SCM_ARG1, s_sys_closedir); - SCM_DEFER_INTS; - if (SCM_CLOSEDP (port)) - { - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; - } - SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port))); - if (sts != 0) - scm_syserror (s_sys_closedir); - SCM_SETCAR (port, scm_tc16_dir); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - - - - -static int scm_dir_print SCM_P ((SCM sexp, SCM port, scm_print_state *pstate)); - -static int -scm_dir_print (sexp, port, pstate) - SCM sexp; - SCM port; - scm_print_state *pstate; -{ - scm_prinport (sexp, port, "directory"); - return 1; -} - - -static scm_sizet scm_dir_free SCM_P ((SCM p)); - -static scm_sizet -scm_dir_free (p) - SCM p; -{ - if (SCM_OPENP (p)) - closedir ((DIR *) SCM_CDR (p)); - return 0; -} - -static scm_smobfuns dir_smob = {scm_mark0, scm_dir_free, scm_dir_print, 0}; - - -/* {Navigating Directories} - */ - - -SCM_PROC (s_sys_chdir, "chdir", 1, 0, 0, scm_sys_chdir); - -SCM -scm_sys_chdir (str) - SCM str; -{ - int ans; - - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_chdir); - SCM_SYSCALL (ans = chdir (SCM_CHARS (str))); - if (ans != 0) - scm_syserror (s_sys_chdir); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_sys_getcwd, "getcwd", 0, 0, 0, scm_sys_getcwd); - -SCM -scm_sys_getcwd () -{ -#ifdef HAVE_GETCWD - char *rv; - - scm_sizet size = 100; - char *wd; - SCM result; - - SCM_DEFER_INTS; - wd = scm_must_malloc (size, s_sys_getcwd); - while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE) - { - scm_must_free (wd); - size *= 2; - wd = scm_must_malloc (size, s_sys_getcwd); - } - if (rv == 0) - scm_syserror (s_sys_getcwd); - result = scm_makfromstr (wd, strlen (wd), 0); - scm_must_free (wd); - SCM_ALLOW_INTS; - return result; -#else - scm_sysmissing (s_sys_getcwd); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - - - -static void fill_select_type SCM_P ((SELECT_TYPE * set, SCM list)); - -static void -fill_select_type (set, list) - SELECT_TYPE * set; - SCM list; -{ - while (list != SCM_EOL) - { - if ( SCM_NIMP (SCM_CAR (list)) - && (scm_tc16_fport == SCM_TYP16 (SCM_CAR (list))) - && SCM_OPPORTP (SCM_CAR (list))) - FD_SET (fileno ((FILE *)SCM_STREAM (SCM_CAR (list))), set); - else if (SCM_INUMP (SCM_CAR (list))) - FD_SET (SCM_INUM (SCM_CAR (list)), set); - else if (SCM_NIMP (SCM_CAR (list)) && SCM_FD_P (SCM_CAR (list))) - FD_SET (SCM_FD (SCM_CAR (list)), set); - list = SCM_CDR (list); - } -} - - -static SCM retrieve_select_type SCM_P ((SELECT_TYPE * set, SCM list)); - -static SCM -retrieve_select_type (set, list) - SELECT_TYPE * set; - SCM list; -{ - SCM answer; - answer = SCM_EOL; - while (list != SCM_EOL) - { - if ( SCM_NIMP (SCM_CAR (list)) - && (scm_tc16_fport == SCM_TYP16 (SCM_CAR (list))) - && SCM_OPPORTP (SCM_CAR (list))) - { - if (FD_ISSET (fileno ((FILE *)SCM_STREAM (SCM_CAR (list))), set)) - answer = scm_cons (SCM_CAR (list), answer); - } - else if (SCM_INUMP (SCM_CAR (list))) - { - if (FD_ISSET (SCM_INUM (SCM_CAR (list)), set)) - answer = scm_cons (SCM_CAR (list), answer); - } - else if (SCM_NIMP (SCM_CAR (list)) && SCM_FD_P (SCM_CAR (list))) - { - if (FD_ISSET (SCM_FD (SCM_CAR (list)), set)) - answer = scm_cons (SCM_CAR (list), answer); - } - list = SCM_CDR (list); - } - return answer; -} - - -/* {Checking for events} - */ - -SCM_PROC (s_sys_select, "select", 3, 2, 0, scm_sys_select); - -SCM -scm_sys_select (reads, writes, excepts, secs, msecs) - SCM reads; - SCM writes; - SCM excepts; - SCM secs; - SCM msecs; -{ -#ifdef HAVE_SELECT - struct timeval timeout; - struct timeval * time_p; - SELECT_TYPE read_set; - SELECT_TYPE write_set; - SELECT_TYPE except_set; - int sreturn; - - SCM_ASSERT (-1 < scm_ilength (reads), reads, SCM_ARG1, s_sys_select); - SCM_ASSERT (-1 < scm_ilength (writes), reads, SCM_ARG1, s_sys_select); - SCM_ASSERT (-1 < scm_ilength (excepts), reads, SCM_ARG1, s_sys_select); - - FD_ZERO (&read_set); - FD_ZERO (&write_set); - FD_ZERO (&except_set); - - fill_select_type (&read_set, reads); - fill_select_type (&write_set, writes); - fill_select_type (&except_set, excepts); - - if (SCM_UNBNDP (secs)) - time_p = 0; - else - { - SCM_ASSERT (SCM_INUMP (secs), secs, SCM_ARG4, s_sys_select); - if (SCM_UNBNDP (msecs)) - msecs = SCM_INUM0; - else - SCM_ASSERT (SCM_INUMP (msecs), msecs, SCM_ARG5, s_sys_select); - - timeout.tv_sec = SCM_INUM (secs); - timeout.tv_usec = 1000 * SCM_INUM (msecs); - time_p = &timeout; - } - - SCM_DEFER_INTS; - sreturn = select (SELECT_SET_SIZE, - &read_set, &write_set, &except_set, time_p); - if (sreturn < 0) - scm_syserror (s_sys_select); - SCM_ALLOW_INTS; - return scm_listify (retrieve_select_type (&read_set, reads), - retrieve_select_type (&write_set, writes), - retrieve_select_type (&except_set, excepts), - SCM_UNDEFINED); -#else - scm_sysmissing (s_sys_select); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -/* Check if FILE has characters waiting to be read. */ - -#ifdef __IBMC__ -# define MSDOS -#endif -#ifdef MSDOS -# ifndef GO32 -# include <io.h> -# include <conio.h> - -int -scm_input_waiting_p (f, caller) - FILE *f; - char *caller; -{ - if (feof (f)) - return 1; - if (fileno (f) == fileno (stdin) && (isatty (fileno (stdin)))) - return kbhit (); - return -1; -} - -# endif -#else -# ifdef _DCC -# include <ioctl.h> -# else -# ifndef AMIGA -# ifndef vms -# ifdef MWC -# include <sys/io.h> -# else -# ifndef THINK_C -# ifndef ARM_ULIB -# include <sys/ioctl.h> -# endif -# endif -# endif -# endif -# endif -# endif - -int -scm_input_waiting_p (f, caller) - FILE *f; - char *caller; -{ - /* Can we return an end-of-file character? */ - if (feof (f)) - return 1; - - /* Do we have characters in the stdio buffer? */ -# ifdef FILE_CNT_FIELD - if (f->FILE_CNT_FIELD > 0) - return 1; -# else -# ifdef FILE_CNT_GPTR - if (f->_gptr != f->_egptr) - return 1; -# else -# ifdef FILE_CNT_READPTR - if (f->_IO_read_end != f->_IO_read_ptr) - return 1; -# else - Configure.in could not guess the name of the correct field in a FILE *. - This function needs to be ported to your system. - It should return zero iff no characters are waiting to be read.; -# endif -# endif -# endif - - /* Is the file prepared to deliver input? */ -# ifdef FIONREAD - { - long remir; - ioctl(fileno(f), FIONREAD, &remir); - return remir; - } -# else -# ifdef HAVE_SELECT - { - struct timeval timeout; - SELECT_TYPE read_set; - SELECT_TYPE write_set; - SELECT_TYPE except_set; - int fno = fileno ((FILE *)f); - - FD_ZERO (&read_set); - FD_ZERO (&write_set); - FD_ZERO (&except_set); - - FD_SET (fno, &read_set); - - timeout.tv_sec = 0; - timeout.tv_usec = 0; - - SCM_DEFER_INTS; - if (select (SELECT_SET_SIZE, - &read_set, &write_set, &except_set, &timeout) - < 0) - scm_syserror (caller); - SCM_ALLOW_INTS; - return FD_ISSET (fno, &read_set); - } -# else - return -1; -# endif -# endif -} -#endif - - -/* {Symbolic Links} - */ - -SCM_PROC (s_sys_symlink, "symlink", 2, 0, 0, scm_sys_symlink); - -SCM -scm_sys_symlink(oldpath, newpath) - SCM oldpath; - SCM newpath; -{ -#ifdef HAVE_SYMLINK - int val; - - SCM_ASSERT(SCM_NIMP(oldpath) && SCM_STRINGP(oldpath), oldpath, SCM_ARG1, s_sys_symlink); - SCM_ASSERT(SCM_NIMP(newpath) && SCM_STRINGP(newpath), newpath, SCM_ARG2, s_sys_symlink); - SCM_SYSCALL (val = symlink(SCM_CHARS(oldpath), SCM_CHARS(newpath))); - if (val != 0) - scm_syserror (s_sys_symlink); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_sys_symlink); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_sys_readlink, "readlink", 1, 0, 0, scm_sys_readlink); - -SCM -scm_sys_readlink(path) - SCM path; -{ -#ifdef HAVE_READLINK - scm_sizet rv; - scm_sizet size = 100; - char *buf; - SCM result; - SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, (char *) SCM_ARG1, s_sys_readlink); - SCM_DEFER_INTS; - buf = scm_must_malloc (size, s_sys_readlink); - while ((rv = readlink (SCM_CHARS (path), buf, (scm_sizet) size)) == size) - { - scm_must_free (buf); - size *= 2; - buf = scm_must_malloc (size, s_sys_readlink); - } - if (rv == -1) - scm_syserror (s_sys_readlink); - result = scm_makfromstr (buf, rv, 0); - scm_must_free (buf); - SCM_ALLOW_INTS; - return result; -#else - scm_sysmissing (s_sys_readlink); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_sys_lstat, "lstat", 1, 0, 0, scm_sys_lstat); - -SCM -scm_sys_lstat(str) - SCM str; -{ -#ifdef HAVE_LSTAT - int rv; - struct stat stat_temp; - - SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, (char *)SCM_ARG1, s_sys_lstat); - SCM_SYSCALL(rv = lstat(SCM_CHARS(str), &stat_temp)); - if (rv != 0) - scm_syserror_msg (s_sys_lstat, "%s: %S", - scm_listify (scm_makfrom0str (strerror (errno)), - str, - SCM_UNDEFINED)); - return scm_stat2scm(&stat_temp); -#else - scm_sysmissing (s_sys_lstat); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_sys_copy_file, "copy-file", 2, 0, 0, scm_sys_copy_file); - -SCM -scm_sys_copy_file (oldfile, newfile) - SCM oldfile; - SCM newfile; -{ - int oldfd, newfd; - int n; - char buf[BUFSIZ]; /* this space could be shared. */ - struct stat oldstat; - - SCM_ASSERT (SCM_NIMP (oldfile) && SCM_ROSTRINGP (oldfile), oldfile, SCM_ARG1, s_sys_copy_file); - if (SCM_SUBSTRP (oldfile)) - oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0); - SCM_ASSERT (SCM_NIMP (newfile) && SCM_ROSTRINGP (newfile), newfile, SCM_ARG2, s_sys_copy_file); - if (SCM_SUBSTRP (newfile)) - newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0); - if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1) - scm_syserror (s_sys_copy_file); - SCM_DEFER_INTS; - oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY); - if (oldfd == -1) - scm_syserror (s_sys_copy_file); - - /* use POSIX flags instead of 07777?. */ - newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC, - oldstat.st_mode & 07777); - if (newfd == -1) - scm_syserror (s_sys_copy_file); - - while ((n = read (oldfd, buf, sizeof buf)) > 0) - if (write (newfd, buf, n) != n) - { - close (oldfd); - close (newfd); - scm_syserror (s_sys_copy_file); - } - close (oldfd); - if (close (newfd) == -1) - scm_syserror (s_sys_copy_file); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - - - -void -scm_init_filesys () -{ - scm_add_feature ("i/o-extensions"); - - scm_tc16_fd = scm_newsmob (&fd_smob); - scm_tc16_dir = scm_newsmob (&dir_smob); - -#include "filesys.x" -} diff --git a/libguile/filesys.h b/libguile/filesys.h deleted file mode 100644 index ff7a28664..000000000 --- a/libguile/filesys.h +++ /dev/null @@ -1,105 +0,0 @@ -/* classes: h_files */ - -#ifndef FILESYSH -#define FILESYSH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "libguile/__scm.h" - - - -extern long scm_tc16_fd; - -#define SCM_FD_P(x) (SCM_TYP16(x)==(scm_tc16_fd)) -#define SCM_FD_FLAGS(x) (SCM_CAR(x) >> 16) -#define SCM_FD(x) ((int)SCM_CDR (x)) - -enum scm_fd_flags -{ - scm_fd_is_open = 1, - scm_close_fd_on_gc = 2 -}; - - - - -extern long scm_tc16_dir; -#define SCM_DIRP(x) (SCM_TYP16(x)==(scm_tc16_dir)) -#define SCM_OPDIRP(x) (SCM_CAR(x)==(scm_tc16_dir | SCM_OPN)) - - - - -extern SCM scm_sys_chown SCM_P ((SCM path, SCM owner, SCM group)); -extern SCM scm_sys_chmod SCM_P ((SCM port_or_path, SCM mode)); -extern SCM scm_umask SCM_P ((SCM mode)); -extern SCM scm_intern_fd SCM_P ((int fd, int flags)); -extern SCM scm_sys_open SCM_P ((SCM path, SCM flags, SCM mode)); -extern SCM scm_sys_create SCM_P ((SCM path, SCM mode)); -extern SCM scm_sys_close SCM_P ((SCM sfd)); -extern SCM scm_sys_write_fd SCM_P ((SCM sfd, SCM buf)); -extern SCM scm_sys_read_fd SCM_P ((SCM sfd, SCM buf, SCM offset, SCM length)); -extern SCM scm_sys_lseek SCM_P ((SCM sfd, SCM offset, SCM whence)); -extern SCM scm_sys_dup SCM_P ((SCM oldfd, SCM newfd)); -extern SCM scm_sys_stat SCM_P ((SCM fd_or_path)); -extern SCM scm_sys_link SCM_P ((SCM oldpath, SCM newpath)); -extern SCM scm_sys_rename SCM_P ((SCM oldname, SCM newname)); -extern SCM scm_sys_delete_file SCM_P ((SCM str)); -extern SCM scm_sys_mkdir SCM_P ((SCM path, SCM mode)); -extern SCM scm_sys_rmdir SCM_P ((SCM path)); -extern SCM scm_sys_opendir SCM_P ((SCM dirname)); -extern SCM scm_sys_readdir SCM_P ((SCM port)); -extern SCM scm_rewinddir SCM_P ((SCM port)); -extern SCM scm_sys_closedir SCM_P ((SCM port)); -extern SCM scm_sys_chdir SCM_P ((SCM str)); -extern SCM scm_sys_getcwd SCM_P ((void)); -extern SCM scm_sys_select SCM_P ((SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs)); -extern int scm_input_waiting_p SCM_P ((FILE *file, char *caller)); -extern SCM scm_sys_symlink SCM_P ((SCM oldpath, SCM newpath)); -extern SCM scm_sys_readlink SCM_P ((SCM path)); -extern SCM scm_sys_lstat SCM_P ((SCM str)); -extern SCM scm_sys_copy_file SCM_P ((SCM oldfile, SCM newfile)); -extern void scm_init_filesys SCM_P ((void)); - -#endif /* FILESYSH */ diff --git a/libguile/fports.c b/libguile/fports.c deleted file mode 100644 index 928aeeff5..000000000 --- a/libguile/fports.c +++ /dev/null @@ -1,400 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "markers.h" - -#include "fports.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#else -scm_sizet fwrite (); -#endif - - -#ifdef __IBMC__ -#include <io.h> -#include <direct.h> -#else -#ifndef MSDOS -#ifndef ultrix -#ifndef vms -#ifdef _DCC -#include <ioctl.h> -#define setbuf(stream, buf) setvbuf(stream, buf, _IONBF, 0) -#else -#ifdef MWC -#include <sys/io.h> -#else -#ifndef THINK_C -#ifndef ARM_ULIB -#include <sys/ioctl.h> -#endif -#endif -#endif -#endif -#endif -#endif -#endif -#endif - - -/* {Ports - file ports} - * - */ - -/* should be called with SCM_DEFER_INTS active */ - -SCM -scm_setbuf0 (port) - SCM port; -{ -#ifndef NOSETBUF -#ifndef MSDOS -#ifdef FIONREAD -#ifndef ultrix - SCM_SYSCALL (setbuf ((FILE *)SCM_STREAM (port), 0);); -#endif -#endif -#endif -#endif - return SCM_UNSPECIFIED; -} - -/* Return the flags that characterize a port based on the mode - * string used to open a file for that port. - * - * See PORT FLAGS in scm.h - */ - -long -scm_mode_bits (modes) - char *modes; -{ - return (SCM_OPN - | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0) - | ( strchr (modes, 'w') - || strchr (modes, 'a') - || strchr (modes, '+') ? SCM_WRTNG : 0) - | (strchr (modes, '0') ? SCM_BUF0 : 0)); -} - - -/* scm_open_file - * Return a new port open on a given file. - * - * The mode string must match the pattern: [rwa+]** which - * is interpreted in the usual unix way. - * - * Return the new port. - */ -SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file); - -SCM -scm_open_file (filename, modes) - SCM filename; - SCM modes; -{ - SCM port; - FILE *f; - char *file; - char *mode; - - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); - if (SCM_SUBSTRP (modes)) - modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0); - - file = SCM_ROCHARS (filename); - mode = SCM_ROCHARS (modes); - - SCM_NEWCELL (port); - SCM_DEFER_INTS; - SCM_SYSCALL (f = fopen (file, mode)); - if (!f) - { - scm_syserror_msg (s_open_file, "%s: %S", - scm_listify (scm_makfrom0str (strerror (errno)), - filename, - SCM_UNDEFINED)); - } - else - { - struct scm_port_table * pt; - - pt = scm_add_to_port_table (port); - SCM_SETPTAB_ENTRY (port, pt); - SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (mode)); - SCM_SETSTREAM (port, (SCM) f); - if (SCM_BUF0 & SCM_CAR (port)) - scm_setbuf0 (port); - SCM_PTAB_ENTRY (port)->file_name = filename; - } - SCM_ALLOW_INTS; - return port; -} - - -/* Build a Scheme port from an open stdio port, FILE. - MODE indicates whether FILE is open for reading or writing; it uses - the same notation as open-file's second argument. - If NAME is non-zero, use it as the port's filename. - - scm_stdio_to_port sets the revealed count for FILE's file - descriptor to 1, so that FILE won't be closed when the port object - is GC'd. */ -SCM -scm_stdio_to_port (file, mode, name) - FILE *file; - char *mode; - char *name; -{ - long mode_bits = scm_mode_bits (mode); - SCM port; - struct scm_port_table * pt; - - SCM_NEWCELL (port); - SCM_DEFER_INTS; - { - pt = scm_add_to_port_table (port); - SCM_SETPTAB_ENTRY (port, pt); - SCM_SETCAR (port, (scm_tc16_fport | mode_bits)); - SCM_SETSTREAM (port, (SCM) file); - if (SCM_BUF0 & SCM_CAR (port)) - scm_setbuf0 (port); - SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name); - } - SCM_ALLOW_INTS; - scm_set_port_revealed_x (port, SCM_MAKINUM (1)); - return port; -} - - -/* Return the mode flags from an open port. - * Some modes such as "append" are only used when opening - * a file and are not returned here. */ - -SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode); - -SCM -scm_port_mode (port) - SCM port; -{ - char modes[3]; - modes[0] = '\0'; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode); - if (SCM_CAR (port) & SCM_RDNG) { - if (SCM_CAR (port) & SCM_WRTNG) - strcpy (modes, "r+"); - else - strcpy (modes, "r"); - } - else if (SCM_CAR (port) & SCM_WRTNG) - strcpy (modes, "w"); - if (SCM_CAR (port) & SCM_BUF0) - strcat (modes, "0"); - return scm_makfromstr (modes, strlen (modes), 0); -} - - - -static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinfport (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - SCM name; - char * c; - if (SCM_CLOSEDP (exp)) - { - c = "file"; - } - else - { - name = SCM_PTAB_ENTRY (exp)->file_name; - if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) - c = SCM_ROCHARS (name); - else - c = "file"; - } - - scm_prinport (exp, port, c); - return !0; -} - - - -static int scm_fgetc SCM_P ((FILE * s)); - -static int -scm_fgetc (s) - FILE * s; -{ - if (feof (s)) - return EOF; - else - return fgetc (s); -} - -#ifdef vms - -static scm_sizet pwrite SCM_P ((char *ptr, scm_sizet size, nitems, FILE *port)); - -static scm_sizet -pwrite (ptr, size, nitems, port) - char *ptr; - scm_sizet size, nitems; - FILE *port; -{ - scm_sizet len = size * nitems; - scm_sizet i = 0; - for (; i < len; i++) - putc (ptr[i], port); - return len; -} - -#define ffwrite pwrite -#else -#define ffwrite fwrite -#endif - - -/* This otherwise pointless code helps some poor - * crippled C compilers cope with life. - */ - -static int local_fclose SCM_P ((FILE *fp)); - -static int -local_fclose (fp) - FILE * fp; -{ - return fclose (fp); -} - -static int local_fflush SCM_P ((FILE *fp)); - -static int -local_fflush (fp) - FILE * fp; -{ - return fflush (fp); -} - -static int local_fputc SCM_P ((int c, FILE *fp)); - -static int -local_fputc (c, fp) - int c; - FILE * fp; -{ - return fputc (c, fp); -} - -static int local_fputs SCM_P ((char *s, FILE *fp)); - -static int -local_fputs (s, fp) - char * s; - FILE * fp; -{ - return fputs (s, fp); -} - -static scm_sizet local_ffwrite SCM_P ((void *ptr, int size, int nitems, FILE *fp)); - -static scm_sizet -local_ffwrite (ptr, size, nitems, fp) - void * ptr; - int size; - int nitems; - FILE * fp; -{ - return ffwrite (ptr, size, nitems, fp); -} - - -scm_ptobfuns scm_fptob = -{ - scm_mark0, - (int (*) SCM_P ((SCM))) local_fclose, - prinfport, - 0, - (int (*) SCM_P ((int, SCM))) local_fputc, - (int (*) SCM_P ((char *, SCM))) local_fputs, - (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite, - (int (*) SCM_P ((SCM))) local_fflush, - (int (*) SCM_P ((SCM))) scm_fgetc, - (int (*) SCM_P ((SCM))) local_fclose -}; - -/* {Pipe ports} - */ -scm_ptobfuns scm_pipob = -{ - scm_mark0, - 0, /* replaced by pclose in scm_init_ioext() */ - 0, /* replaced by prinpipe in scm_init_ioext() */ - 0, - (int (*) SCM_P ((int, SCM))) local_fputc, - (int (*) SCM_P ((char *, SCM))) local_fputs, - (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite, - (int (*) SCM_P ((SCM))) local_fflush, - (int (*) SCM_P ((SCM))) scm_fgetc, - 0 -}; /* replaced by pclose in scm_init_ioext() */ - -void -scm_init_fports () -{ -#include "fports.x" -} diff --git a/libguile/fports.h b/libguile/fports.h deleted file mode 100644 index 13802d345..000000000 --- a/libguile/fports.h +++ /dev/null @@ -1,65 +0,0 @@ -/* classes: h_files */ - -#ifndef FPORTSH -#define FPORTSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -#include "libguile/ports.h" - - - -extern scm_ptobfuns scm_fptob; -extern scm_ptobfuns scm_pipob; - - - -extern SCM scm_setbuf0 SCM_P ((SCM port)); -extern long scm_mode_bits SCM_P ((char *modes)); -extern SCM scm_open_file SCM_P ((SCM filename, SCM modes)); -extern SCM scm_stdio_to_port SCM_P ((FILE *file, char *name, char *modes)); -extern SCM scm_port_mode SCM_P ((SCM port)); -extern void scm_init_fports SCM_P ((void)); - -#endif /* FPORTSH */ diff --git a/libguile/gc.c b/libguile/gc.c deleted file mode 100644 index cd4a249d7..000000000 --- a/libguile/gc.c +++ /dev/null @@ -1,1825 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "stime.h" -#include "stackchk.h" -#include "struct.h" -#include "genio.h" -#include "weaks.h" -#include "smob.h" -#include "unif.h" -#include "async.h" - -#include "gc.h" - -#ifdef HAVE_MALLOC_H -#include <malloc.h> -#endif - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - -#ifdef __STDC__ -#include <stdarg.h> -#define var_start(x, y) va_start(x, y) -#else -#include <varargs.h> -#define var_start(x, y) va_start(x) -#endif - - -/* {heap tuning parameters} - * - * These are parameters for controlling memory allocation. The heap - * is the area out of which scm_cons, and object headers are allocated. - * - * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a - * 64 bit machine. The units of the _SIZE parameters are bytes. - * Cons pairs and object headers occupy one heap cell. - * - * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is - * allocated initially the heap will grow by half its current size - * each subsequent time more heap is needed. - * - * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE - * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more - * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code - * is in scm_init_storage() and alloc_some_heap() in sys.c - * - * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by - * SCM_EXPHEAP(scm_heap_size) when more heap is needed. - * - * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap - * is needed. - * - * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will - * trigger a GC. - * - * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be - * reclaimed by a GC triggered by must_malloc. If less than this is - * reclaimed, the trigger threshold is raised. [I don't know what a - * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to - * work around a oscillation that caused almost constant GC.] - */ - -#define SCM_INIT_HEAP_SIZE (32768L*sizeof(scm_cell)) -#define SCM_MIN_HEAP_SEG_SIZE (2048L*sizeof(scm_cell)) -#ifdef _QC -# define SCM_HEAP_SEG_SIZE 32768L -#else -# ifdef sequent -# define SCM_HEAP_SEG_SIZE (7000L*sizeof(scm_cell)) -# else -# define SCM_HEAP_SEG_SIZE (16384L*sizeof(scm_cell)) -# endif -#endif -#define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2) -#define SCM_INIT_MALLOC_LIMIT 100000 -#define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10) - -/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner - bounds for allocated storage */ - -#ifdef PROT386 -/*in 386 protected mode we must only adjust the offset */ -# define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7)) -# define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p)) -#else -# ifdef _UNICOS -# define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L)) -# define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p)) -# else -# define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L)) -# define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p)) -# endif /* UNICOS */ -#endif /* PROT386 */ - - - -/* scm_freelist - * is the head of freelist of cons pairs. - */ -SCM scm_freelist = SCM_EOL; - -/* scm_mtrigger - * is the number of bytes of must_malloc allocation needed to trigger gc. - */ -long scm_mtrigger; - - -/* scm_gc_heap_lock - * If set, don't expand the heap. Set only during gc, during which no allocation - * is supposed to take place anyway. - */ -int scm_gc_heap_lock = 0; - -/* GC Blocking - * Don't pause for collection if this is set -- just - * expand the heap. - */ - -int scm_block_gc = 1; - -/* If fewer than MIN_GC_YIELD cells are recovered during a garbage - * collection (GC) more space is allocated for the heap. - */ -#define MIN_GC_YIELD (scm_heap_size/4) - -/* During collection, this accumulates objects holding - * weak references. - */ -SCM *scm_weak_vectors; -int scm_weak_size; -int scm_n_weak; - -/* GC Statistics Keeping - */ -unsigned long scm_cells_allocated = 0; -unsigned long scm_mallocated = 0; -unsigned long scm_gc_cells_collected; -unsigned long scm_gc_malloc_collected; -unsigned long scm_gc_ports_collected; -unsigned long scm_gc_rt; -unsigned long scm_gc_time_taken = 0; - -SCM_SYMBOL (sym_cells_allocated, "cells-allocated"); -SCM_SYMBOL (sym_heap_size, "cell-heap-size"); -SCM_SYMBOL (sym_mallocated, "bytes-malloced"); -SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold"); -SCM_SYMBOL (sym_heap_segments, "cell-heap-segments"); -SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken"); - - -struct scm_heap_seg_data -{ - /* lower and upper bounds of the segment */ - SCM_CELLPTR bounds[2]; - - /* address of the head-of-freelist pointer for this segment's cells. - All segments usually point to the same one, scm_freelist. */ - SCM *freelistp; - - /* number of SCM words per object in this segment */ - int ncells; - - /* If SEG_DATA->valid is non-zero, the conservative marking - functions will apply SEG_DATA->valid to the purported pointer and - SEG_DATA, and mark the object iff the function returns non-zero. - At the moment, I don't think anyone uses this. */ - int (*valid) (); -}; - - - - -static void scm_mark_weak_vector_spines SCM_P ((void)); -static scm_sizet init_heap_seg SCM_P ((SCM_CELLPTR, scm_sizet, int, SCM *)); -static void alloc_some_heap SCM_P ((int, SCM *)); - - - -/* Debugging functions. */ - -#ifdef DEBUG_FREELIST - -/* Return the number of the heap segment containing CELL. */ -static int -which_seg (SCM cell) -{ - int i; - - for (i = 0; i < scm_n_heap_segs; i++) - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], (SCM_CELLPTR) cell) - && SCM_PTR_GT (scm_heap_table[i].bounds[1], (SCM_CELLPTR) cell)) - return i; - fprintf (stderr, "which_seg: can't find segment containing cell %lx\n", - cell); - abort (); -} - - -SCM_PROC (s_map_free_list, "map-free-list", 0, 0, 0, scm_map_free_list); -SCM -scm_map_free_list () -{ - int last_seg = -1, count = 0; - SCM f; - - fprintf (stderr, "%d segments total\n", scm_n_heap_segs); - for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f)) - { - int this_seg = which_seg (f); - - if (this_seg != last_seg) - { - if (last_seg != -1) - fprintf (stderr, " %5d cells in segment %d\n", count, last_seg); - last_seg = this_seg; - count = 0; - } - count++; - } - if (last_seg != -1) - fprintf (stderr, " %5d cells in segment %d\n", count, last_seg); - - fflush (stderr); - - return SCM_UNSPECIFIED; -} - - -/* Number of calls to SCM_NEWCELL since startup. */ -static unsigned long scm_newcell_count; - -/* Search freelist for anything that isn't marked as a free cell. - Abort if we find something. */ -static void -scm_check_freelist () -{ - SCM f; - int i = 0; - - for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f), i++) - if (SCM_CAR (f) != (SCM) scm_tc_free_cell) - { - fprintf (stderr, "Bad cell in freelist on newcell %lu: %d'th elt\n", - scm_newcell_count, i); - fflush (stderr); - abort (); - } -} - -static int scm_debug_check_freelist = 0; -void -scm_debug_newcell (SCM *into) -{ - scm_newcell_count++; - if (scm_debug_check_freelist) - scm_check_freelist (); - - /* The rest of this is supposed to be identical to the SCM_NEWCELL - macro. */ - if (SCM_IMP (scm_freelist)) - *into = scm_gc_for_newcell (); - else - { - *into = scm_freelist; - scm_freelist = SCM_CDR (scm_freelist); - ++scm_cells_allocated; - } -} - -#endif /* DEBUG_FREELIST */ - - - -/* {Scheme Interface to GC} - */ - -SCM_PROC (s_gc_stats, "gc-stats", 0, 0, 0, scm_gc_stats); -SCM -scm_gc_stats () -{ - int i; - int n; - SCM heap_segs; - SCM local_scm_mtrigger; - SCM local_scm_mallocated; - SCM local_scm_heap_size; - SCM local_scm_cells_allocated; - SCM local_scm_gc_time_taken; - SCM answer; - - SCM_DEFER_INTS; - scm_block_gc = 1; - retry: - heap_segs = SCM_EOL; - n = scm_n_heap_segs; - for (i = scm_n_heap_segs; i--; ) - heap_segs = scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[1]), - scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[0])), - heap_segs); - if (scm_n_heap_segs != n) - goto retry; - scm_block_gc = 0; - - local_scm_mtrigger = scm_mtrigger; - local_scm_mallocated = scm_mallocated; - local_scm_heap_size = scm_heap_size; - local_scm_cells_allocated = scm_cells_allocated; - local_scm_gc_time_taken = scm_gc_time_taken; - - answer = scm_listify (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)), - scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)), - scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)), - scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)), - scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)), - scm_cons (sym_heap_segments, heap_segs), - SCM_UNDEFINED); - SCM_ALLOW_INTS; - return answer; -} - - -void -scm_gc_start (what) - char *what; -{ - scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()); - scm_gc_cells_collected = 0; - scm_gc_malloc_collected = 0; - scm_gc_ports_collected = 0; -} - -void -scm_gc_end () -{ - scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt; - scm_gc_time_taken = scm_gc_time_taken + scm_gc_rt; - scm_take_signal (SCM_GC_SIGNAL); -} - - -SCM_PROC(s_object_address, "object-address", 1, 0, 0, scm_object_addr); -SCM -scm_object_addr (obj) - SCM obj; -{ - return scm_ulong2num ((unsigned long)obj); -} - - -SCM_PROC(s_gc, "gc", 0, 0, 0, scm_gc); -SCM -scm_gc () -{ - SCM_DEFER_INTS; - scm_igc ("call"); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - - - -/* {C Interface For When GC is Triggered} - */ - -void -scm_gc_for_alloc (ncells, freelistp) - int ncells; - SCM * freelistp; -{ - SCM_REDEFER_INTS; - scm_igc ("cells"); - if ((scm_gc_cells_collected < MIN_GC_YIELD) || SCM_IMP (*freelistp)) - { - alloc_some_heap (ncells, freelistp); - } - SCM_REALLOW_INTS; -} - - -SCM -scm_gc_for_newcell () -{ - SCM fl; - scm_gc_for_alloc (1, &scm_freelist); - fl = scm_freelist; - scm_freelist = SCM_CDR (fl); - return fl; -} - -void -scm_igc (what) - char *what; -{ - int j; - -#ifdef USE_THREADS - /* During the critical section, only the current thread may run. */ - SCM_THREAD_CRITICAL_SECTION_START; -#endif - - scm_gc_start (what); - if (!scm_stack_base || scm_block_gc) - { - scm_gc_end (); - return; - } - - ++scm_gc_heap_lock; - scm_n_weak = 0; - - /* unprotect any struct types with no instances */ -#if 0 - { - SCM type_list; - SCM * pos; - - pos = &scm_type_obj_list; - type_list = scm_type_obj_list; - while (type_list != SCM_EOL) - if (SCM_VELTS (SCM_CAR (type_list))[scm_struct_i_refcnt]) - { - pos = SCM_CDRLOC (type_list); - type_list = SCM_CDR (type_list); - } - else - { - *pos = SCM_CDR (type_list); - type_list = SCM_CDR (type_list); - } - } -#endif - - /* flush dead entries from the continuation stack */ - { - int x; - int bound; - SCM * elts; - elts = SCM_VELTS (scm_continuation_stack); - bound = SCM_LENGTH (scm_continuation_stack); - x = SCM_INUM (scm_continuation_stack_ptr); - while (x < bound) - { - elts[x] = SCM_BOOL_F; - ++x; - } - } - -#ifndef USE_THREADS - - /* Protect from the C stack. This must be the first marking - * done because it provides information about what objects - * are "in-use" by the C code. "in-use" objects are those - * for which the values from SCM_LENGTH and SCM_CHARS must remain - * usable. This requirement is stricter than a liveness - * requirement -- in particular, it constrains the implementation - * of scm_vector_set_length_x. - */ - SCM_FLUSH_REGISTER_WINDOWS; - /* This assumes that all registers are saved into the jmp_buf */ - setjmp (scm_save_regs_gc_mark); - scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark, - ( (scm_sizet) (sizeof (SCM_STACKITEM) - 1 + - sizeof scm_save_regs_gc_mark) - / sizeof (SCM_STACKITEM))); - - { - /* stack_len is long rather than scm_sizet in order to guarantee that - &stack_len is long aligned */ -#ifdef SCM_STACK_GROWS_UP -#ifdef nosve - long stack_len = (SCM_STACKITEM *) (&stack_len) - scm_stack_base; -#else - long stack_len = scm_stack_size (scm_stack_base); -#endif - scm_mark_locations (scm_stack_base, (scm_sizet) stack_len); -#else -#ifdef nosve - long stack_len = scm_stack_base - (SCM_STACKITEM *) (&stack_len); -#else - long stack_len = scm_stack_size (scm_stack_base); -#endif - scm_mark_locations ((scm_stack_base - stack_len), (scm_sizet) stack_len); -#endif - } - -#else /* USE_THREADS */ - - /* Mark every thread's stack and registers */ - scm_threads_mark_stacks(); - -#endif /* USE_THREADS */ - - /* FIXME: insert a phase to un-protect string-data preserved - * in scm_vector_set_length_x. - */ - - j = SCM_NUM_PROTECTS; - while (j--) - scm_gc_mark (scm_sys_protects[j]); - -#ifndef USE_THREADS - scm_gc_mark (scm_root->handle); -#endif - - scm_mark_weak_vector_spines (); - - scm_gc_sweep (); - - --scm_gc_heap_lock; - scm_gc_end (); - -#ifdef USE_THREADS - SCM_THREAD_CRITICAL_SECTION_END; -#endif -} - - -/* {Mark/Sweep} - */ - - - -/* Mark an object precisely. - */ -void -scm_gc_mark (p) - SCM p; -{ - register long i; - register SCM ptr; - - ptr = p; - -gc_mark_loop: - if (SCM_IMP (ptr)) - return; - -gc_mark_nimp: - if (SCM_NCELLP (ptr)) - scm_wta (ptr, "rogue pointer in ", "heap"); - - switch (SCM_TYP7 (ptr)) - { - case scm_tcs_cons_nimcar: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - if (SCM_IMP (SCM_CDR (ptr))) /* SCM_IMP works even with a GC mark */ - { - ptr = SCM_CAR (ptr); - goto gc_mark_nimp; - } - scm_gc_mark (SCM_CAR (ptr)); - ptr = SCM_GCCDR (ptr); - goto gc_mark_nimp; - case scm_tcs_cons_imcar: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - ptr = SCM_GCCDR (ptr); - goto gc_mark_loop; - case scm_tcs_cons_gloc: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - { - SCM vcell; - vcell = SCM_CAR (ptr) - 1L; - switch (SCM_CDR (vcell)) - { - default: - scm_gc_mark (vcell); - ptr = SCM_GCCDR (ptr); - goto gc_mark_loop; - case 1: /* ! */ - case 0: /* ! */ - { - SCM layout; - SCM * vtable_data; - int len; - char * fields_desc; - register SCM * mem; - register int x; - - vtable_data = (SCM *)vcell; - layout = vtable_data[scm_struct_i_layout]; - len = SCM_LENGTH (layout); - fields_desc = SCM_CHARS (layout); - /* We're using SCM_GCCDR here like STRUCT_DATA, except - that it removes the mark */ - mem = (SCM *)SCM_GCCDR (ptr); - - if (len) - { - for (x = 0; x < len - 2; x += 2, ++mem) - if (fields_desc[x] == 'p') - scm_gc_mark (*mem); - if (fields_desc[x] == 'p') - { - if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) - for (x = *mem; x; --x) - scm_gc_mark (*++mem); - else - scm_gc_mark (*mem); - } - } - if (!SCM_CDR (vcell)) - { - SCM_SETGCMARK (vcell); - ptr = vtable_data[scm_struct_i_vtable]; - goto gc_mark_loop; - } - } - } - } - break; - case scm_tcs_closures: - if (SCM_GCMARKP (ptr)) - break; - SCM_SETGCMARK (ptr); - if (SCM_IMP (SCM_CDR (ptr))) - { - ptr = SCM_CLOSCAR (ptr); - goto gc_mark_nimp; - } - scm_gc_mark (SCM_CLOSCAR (ptr)); - ptr = SCM_GCCDR (ptr); - goto gc_mark_nimp; - case scm_tc7_vector: - case scm_tc7_lvector: -#ifdef CCLO - case scm_tc7_cclo: -#endif - if (SCM_GC8MARKP (ptr)) - break; - SCM_SETGC8MARK (ptr); - i = SCM_LENGTH (ptr); - if (i == 0) - break; - while (--i > 0) - if (SCM_NIMP (SCM_VELTS (ptr)[i])) - scm_gc_mark (SCM_VELTS (ptr)[i]); - ptr = SCM_VELTS (ptr)[0]; - goto gc_mark_loop; - case scm_tc7_contin: - if SCM_GC8MARKP - (ptr) break; - SCM_SETGC8MARK (ptr); - scm_mark_locations (SCM_VELTS (ptr), - (scm_sizet) - (SCM_LENGTH (ptr) + - (sizeof (SCM_STACKITEM) + -1 + sizeof (scm_contregs)) / - sizeof (SCM_STACKITEM))); - break; - case scm_tc7_bvect: - case scm_tc7_byvect: - case scm_tc7_ivect: - case scm_tc7_uvect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - - case scm_tc7_string: - case scm_tc7_mb_string: - SCM_SETGC8MARK (ptr); - break; - - case scm_tc7_substring: - case scm_tc7_mb_substring: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); - ptr = SCM_CDR (ptr); - goto gc_mark_loop; - - case scm_tc7_wvect: - if (SCM_GC8MARKP(ptr)) - break; - scm_weak_vectors[scm_n_weak++] = ptr; - if (scm_n_weak >= scm_weak_size) - { - SCM_SYSCALL (scm_weak_vectors = - (SCM *) realloc ((char *) scm_weak_vectors, - sizeof (SCM *) * (scm_weak_size *= 2))); - if (scm_weak_vectors == NULL) - { - scm_gen_puts (scm_regular_string, - "weak vector table", - scm_cur_errp); - scm_gen_puts (scm_regular_string, - "\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n", - scm_cur_errp); - exit(SCM_EXIT_FAILURE); - } - } - SCM_SETGC8MARK (ptr); - if (SCM_IS_WHVEC_ANY (ptr)) - { - int x; - int len; - int weak_keys; - int weak_values; - - len = SCM_LENGTH (ptr); - weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr); - weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr); - - for (x = 0; x < len; ++x) - { - SCM alist; - alist = SCM_VELTS (ptr)[x]; - /* mark everything on the alist - * except the keys or values, according to weak_values and weak_keys. - */ - while ( SCM_NIMP (alist) - && SCM_CONSP (alist) - && !SCM_GCMARKP (alist) - && SCM_NIMP (SCM_CAR (alist)) - && SCM_CONSP (SCM_CAR (alist))) - { - SCM kvpair; - SCM next_alist; - - kvpair = SCM_CAR (alist); - next_alist = SCM_CDR (alist); - /* - * Do not do this: - * SCM_SETGCMARK (alist); - * SCM_SETGCMARK (kvpair); - * - * It may be that either the key or value is protected by - * an escaped reference to part of the spine of this alist. - * If we mark the spine here, and only mark one or neither of the - * key and value, they may never be properly marked. - * This leads to a horrible situation in which an alist containing - * freelist cells is exported. - * - * So only mark the spines of these arrays last of all marking. - * If somebody confuses us by constructing a weak vector - * with a circular alist then we are hosed, but at least we - * won't prematurely drop table entries. - */ - if (!weak_keys) - scm_gc_mark (SCM_CAR (kvpair)); - if (!weak_values) - scm_gc_mark (SCM_GCCDR (kvpair)); - alist = next_alist; - } - if (SCM_NIMP (alist)) - scm_gc_mark (alist); - } - } - break; - - case scm_tc7_msymbol: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); - scm_gc_mark (SCM_SYMBOL_FUNC (ptr)); - ptr = SCM_SYMBOL_PROPS (ptr); - goto gc_mark_loop; - case scm_tc7_ssymbol: - if (SCM_GC8MARKP(ptr)) - break; - SCM_SETGC8MARK (ptr); - break; - case scm_tcs_subrs: - ptr = (SCM)(scm_heap_org + (((unsigned long)SCM_CAR (ptr)) >> 8)); - goto gc_mark_loop; - case scm_tc7_port: - i = SCM_PTOBNUM (ptr); - if (!(i < scm_numptob)) - goto def; - if (SCM_GC8MARKP (ptr)) - break; - if (SCM_PTAB_ENTRY(ptr)) - scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name); - ptr = (scm_ptobs[i].mark) (ptr); - goto gc_mark_loop; - break; - case scm_tc7_smob: - if (SCM_GC8MARKP (ptr)) - break; - switch SCM_TYP16 (ptr) - { /* should be faster than going through scm_smobs */ - case scm_tc_free_cell: - /* printf("found free_cell %X ", ptr); fflush(stdout); */ - SCM_SETGC8MARK (ptr); - SCM_SETCDR (ptr, SCM_EOL); - break; - case scm_tcs_bignums: - case scm_tc16_flo: - SCM_SETGC8MARK (ptr); - break; - default: - i = SCM_SMOBNUM (ptr); - if (!(i < scm_numsmob)) - goto def; - ptr = (scm_smobs[i].mark) (ptr); - goto gc_mark_loop; - } - break; - default: - def:scm_wta (ptr, "unknown type in ", "gc_mark"); - } -} - - -/* Mark a Region Conservatively - */ - -void -scm_mark_locations (x, n) - SCM_STACKITEM x[]; - scm_sizet n; -{ - register long m = n; - register int i, j; - register SCM_CELLPTR ptr; - - while (0 <= --m) - if SCM_CELLP (*(SCM **) & x[m]) - { - ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & x[m])); - i = 0; - j = scm_n_heap_segs - 1; - if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) - && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - { - while (i <= j) - { - int seg_id; - seg_id = -1; - if ( (i == j) - || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)) - seg_id = i; - else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr)) - seg_id = j; - else - { - int k; - k = (i + j) / 2; - if (k == i) - break; - if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) - { - j = k; - ++i; - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)) - continue; - else - break; - } - else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) - { - i = k; - --j; - if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - continue; - else - break; - } - } - if ( !scm_heap_table[seg_id].valid - || scm_heap_table[seg_id].valid (ptr, - &scm_heap_table[seg_id])) - scm_gc_mark (*(SCM *) & x[m]); - break; - } - - } - } -} - - -/* The following is a C predicate which determines if an SCM value can be - regarded as a pointer to a cell on the heap. The code is duplicated - from scm_mark_locations. */ - - -int -scm_cellp (value) - SCM value; -{ - register int i, j; - register SCM_CELLPTR ptr; - - if SCM_CELLP (*(SCM **) & value) - { - ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value)); - i = 0; - j = scm_n_heap_segs - 1; - if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr) - && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - { - while (i <= j) - { - int seg_id; - seg_id = -1; - if ( (i == j) - || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr)) - seg_id = i; - else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr)) - seg_id = j; - else - { - int k; - k = (i + j) / 2; - if (k == i) - break; - if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr)) - { - j = k; - ++i; - if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)) - continue; - else - break; - } - else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr)) - { - i = k; - --j; - if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr)) - continue; - else - break; - } - } - if ( !scm_heap_table[seg_id].valid - || scm_heap_table[seg_id].valid (ptr, - &scm_heap_table[seg_id])) - return 1; - break; - } - - } - } - return 0; -} - - -static void -scm_mark_weak_vector_spines () -{ - int i; - - for (i = 0; i < scm_n_weak; ++i) - { - if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) - { - SCM *ptr; - SCM obj; - int j; - int n; - - obj = scm_weak_vectors[i]; - ptr = SCM_VELTS (scm_weak_vectors[i]); - n = SCM_LENGTH (scm_weak_vectors[i]); - for (j = 0; j < n; ++j) - { - SCM alist; - - alist = ptr[j]; - while ( SCM_NIMP (alist) - && SCM_CONSP (alist) - && !SCM_GCMARKP (alist) - && SCM_NIMP (SCM_CAR (alist)) - && SCM_CONSP (SCM_CAR (alist))) - { - SCM_SETGCMARK (alist); - SCM_SETGCMARK (SCM_CAR (alist)); - alist = SCM_GCCDR (alist); - } - } - } - } -} - - - -void -scm_gc_sweep () -{ - register SCM_CELLPTR ptr; -#ifdef SCM_POINTERS_MUNGED - register SCM scmptr; -#else -#undef scmptr -#define scmptr (SCM)ptr -#endif - register SCM nfreelist; - register SCM *hp_freelist; - register long n; - register long m; - register scm_sizet j; - register int span; - scm_sizet i; - scm_sizet seg_size; - - n = 0; - m = 0; - - /* Reset all free list pointers. We'll reconstruct them completely - while scanning. */ - for (i = 0; i < scm_n_heap_segs; i++) - *scm_heap_table[i].freelistp = SCM_EOL; - - for (i = 0; i < scm_n_heap_segs; i++) - { - /* Unmarked cells go onto the front of the freelist this heap - segment points to. Rather than updating the real freelist - pointer as we go along, we accumulate the new head in - nfreelist. Then, if it turns out that the entire segment is - free, we free (i.e., malloc's free) the whole segment, and - simply don't assign nfreelist back into the real freelist. */ - hp_freelist = scm_heap_table[i].freelistp; - nfreelist = *hp_freelist; - - span = scm_heap_table[i].ncells; - ptr = CELL_UP (scm_heap_table[i].bounds[0]); - seg_size = CELL_DN (scm_heap_table[i].bounds[1]) - ptr; - for (j = seg_size + span; j -= span; ptr += span) - { -#ifdef SCM_POINTERS_MUNGED - scmptr = PTR2SCM (ptr); -#endif - switch SCM_TYP7 (scmptr) - { - case scm_tcs_cons_gloc: - if (SCM_GCMARKP (scmptr)) - { - if (SCM_CDR (SCM_CAR (scmptr) - 1) == (SCM)1) - SCM_SETCDR (SCM_CAR (scmptr) - 1, (SCM) 0); - goto cmrkcontinue; - } - { - SCM vcell; - vcell = SCM_CAR (scmptr) - 1L; - - if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1)) - { - SCM *p = (SCM *) SCM_GCCDR (scmptr); - m += p[scm_struct_i_n_words] * sizeof (SCM); - /* I feel like I'm programming in BCPL here... */ - free ((char *) p[scm_struct_i_ptr]); - } - } - break; - case scm_tcs_cons_imcar: - case scm_tcs_cons_nimcar: - case scm_tcs_closures: - if (SCM_GCMARKP (scmptr)) - goto cmrkcontinue; - break; - case scm_tc7_wvect: - if (SCM_GC8MARKP (scmptr)) - { - goto c8mrkcontinue; - } - else - { - m += (1 + SCM_LENGTH (scmptr)) * sizeof (SCM); - scm_must_free ((char *)(SCM_VELTS (scmptr) - 1)); - break; - } - - case scm_tc7_vector: - case scm_tc7_lvector: -#ifdef CCLO - case scm_tc7_cclo: -#endif - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - - m += (SCM_LENGTH (scmptr) * sizeof (SCM)); - freechars: - scm_must_free (SCM_CHARS (scmptr)); - /* SCM_SETCHARS(scmptr, 0);*/ - break; - case scm_tc7_bvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += sizeof (long) * ((SCM_HUGE_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - goto freechars; - case scm_tc7_byvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (char); - goto freechars; - case scm_tc7_ivect: - case scm_tc7_uvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (long); - goto freechars; - case scm_tc7_svect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (short); - goto freechars; -#ifdef LONGLONGS - case scm_tc7_llvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (long_long); - goto freechars; -#endif - case scm_tc7_fvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (float); - goto freechars; - case scm_tc7_dvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * sizeof (double); - goto freechars; - case scm_tc7_cvect: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double); - goto freechars; - case scm_tc7_substring: - case scm_tc7_mb_substring: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - break; - case scm_tc7_string: - case scm_tc7_mb_string: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - m += SCM_HUGE_LENGTH (scmptr) + 1; - goto freechars; - case scm_tc7_msymbol: - if (SCM_GC8MARKP (scmptr)) - goto c8mrkcontinue; - m += ( SCM_LENGTH (scmptr) - + 1 - + sizeof (SCM) * ((SCM *)SCM_CHARS (scmptr) - SCM_SLOTS(scmptr))); - scm_must_free ((char *)SCM_SLOTS (scmptr)); - break; - case scm_tc7_contin: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs); - goto freechars; - case scm_tc7_ssymbol: - if SCM_GC8MARKP(scmptr) - goto c8mrkcontinue; - break; - case scm_tcs_subrs: - continue; - case scm_tc7_port: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - if SCM_OPENP (scmptr) - { - int k = SCM_PTOBNUM (scmptr); - if (!(k < scm_numptob)) - goto sweeperr; - /* Keep "revealed" ports alive. */ - if (scm_revealed_count(scmptr) > 0) - continue; - /* Yes, I really do mean scm_ptobs[k].free */ - /* rather than ftobs[k].close. .close */ - /* is for explicit CLOSE-PORT by user */ - (scm_ptobs[k].free) (SCM_STREAM (scmptr)); - SCM_SETSTREAM (scmptr, 0); - scm_remove_from_port_table (scmptr); - scm_gc_ports_collected++; - SCM_SETAND_CAR (scmptr, ~SCM_OPN); - } - break; - case scm_tc7_smob: - switch SCM_GCTYP16 (scmptr) - { - case scm_tc_free_cell: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - break; -#ifdef SCM_BIGDIG - case scm_tcs_bignums: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT); - goto freechars; -#endif /* def SCM_BIGDIG */ - case scm_tc16_flo: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - switch ((int) (SCM_CAR (scmptr) >> 16)) - { - case (SCM_IMAG_PART | SCM_REAL_PART) >> 16: - m += sizeof (double); - case SCM_REAL_PART >> 16: - case SCM_IMAG_PART >> 16: - m += sizeof (double); - goto freechars; - case 0: - break; - default: - goto sweeperr; - } - break; - default: - if SCM_GC8MARKP (scmptr) - goto c8mrkcontinue; - - { - int k; - k = SCM_SMOBNUM (scmptr); - if (!(k < scm_numsmob)) - goto sweeperr; - m += (scm_smobs[k].free) ((SCM) scmptr); - break; - } - } - break; - default: - sweeperr:scm_wta (scmptr, "unknown type in ", "gc_sweep"); - } - n += span; -#if 0 - if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell) - exit (2); -#endif - /* Stick the new cell on the front of nfreelist. */ - SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell); - SCM_SETCDR (scmptr, nfreelist); - nfreelist = scmptr; - - continue; - c8mrkcontinue: - SCM_CLRGC8MARK (scmptr); - continue; - cmrkcontinue: - SCM_CLRGCMARK (scmptr); - } -#ifdef GC_FREE_SEGMENTS - if (n == seg_size) - { - scm_heap_size -= seg_size; - free ((char *) scm_heap_table[i].bounds[0]); - scm_heap_table[i].bounds[0] = 0; - for (j = i + 1; j < scm_n_heap_segs; j++) - scm_heap_table[j - 1] = scm_heap_table[j]; - scm_n_heap_segs -= 1; - i--; /* We need to scan the segment just moved. */ - } - else -#endif /* ifdef GC_FREE_SEGMENTS */ - /* Update the real freelist pointer to point to the head of - the list of free cells we've built for this segment. */ - *hp_freelist = nfreelist; - -#ifdef DEBUG_FREELIST - scm_check_freelist (); - scm_map_free_list (); -#endif - - scm_gc_cells_collected += n; - n = 0; - } - /* Scan weak vectors. */ - { - SCM *ptr; - for (i = 0; i < scm_n_weak; ++i) - { - if (!SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) - { - ptr = SCM_VELTS (scm_weak_vectors[i]); - n = SCM_LENGTH (scm_weak_vectors[i]); - for (j = 0; j < n; ++j) - if (SCM_NIMP (ptr[j]) && SCM_FREEP (ptr[j])) - ptr[j] = SCM_BOOL_F; - } - else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */ - { - SCM obj; - obj = scm_weak_vectors[i]; - ptr = SCM_VELTS (scm_weak_vectors[i]); - n = SCM_LENGTH (scm_weak_vectors[i]); - for (j = 0; j < n; ++j) - { - SCM * fixup; - SCM alist; - int weak_keys; - int weak_values; - - weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj); - weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj); - - fixup = ptr + j; - alist = *fixup; - - while (SCM_NIMP (alist) - && SCM_CONSP (alist) - && SCM_NIMP (SCM_CAR (alist)) - && SCM_CONSP (SCM_CAR (alist))) - { - SCM key; - SCM value; - - key = SCM_CAAR (alist); - value = SCM_CDAR (alist); - if ( (weak_keys && SCM_NIMP (key) && SCM_FREEP (key)) - || (weak_values && SCM_NIMP (value) && SCM_FREEP (value))) - { - *fixup = SCM_CDR (alist); - } - else - fixup = SCM_CDRLOC (alist); - alist = SCM_CDR (alist); - } - } - } - } - } - scm_cells_allocated = (scm_heap_size - scm_gc_cells_collected); - scm_mallocated -= m; - scm_gc_malloc_collected = m; -} - - - - -/* {Front end to malloc} - * - * scm_must_malloc, scm_must_realloc, scm_must_free - * - * These functions provide services comperable to malloc, realloc, and - * free. They are for allocating malloced parts of scheme objects. - * The primary purpose of the front end is to impose calls to gc. - */ - -/* scm_must_malloc - * Return newly malloced storage or throw an error. - * - * The parameter WHAT is a string for error reporting. - * If the threshold scm_mtrigger will be passed by this - * allocation, or if the first call to malloc fails, - * garbage collect -- on the presumption that some objects - * using malloced storage may be collected. - * - * The limit scm_mtrigger may be raised by this allocation. - */ -char * -scm_must_malloc (len, what) - long len; - char *what; -{ - char *ptr; - scm_sizet size = len; - long nm = scm_mallocated + size; - if (len != size) - malerr: - scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what); - if ((nm <= scm_mtrigger)) - { - SCM_SYSCALL (ptr = (char *) malloc (size)); - if (NULL != ptr) - { - scm_mallocated = nm; - return ptr; - } - } - - scm_igc (what); - nm = scm_mallocated + size; - SCM_SYSCALL (ptr = (char *) malloc (size)); - if (NULL != ptr) - { - scm_mallocated = nm; - if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { - if (nm > scm_mtrigger) - scm_mtrigger = nm + nm / 2; - else - scm_mtrigger += scm_mtrigger / 2; - } - return ptr; - } - goto malerr; -} - - -/* scm_must_realloc - * is similar to scm_must_malloc. - */ -char * -scm_must_realloc (where, olen, len, what) - char *where; - long olen; - long len; - char *what; -{ - char *ptr; - scm_sizet size = len; - long nm = scm_mallocated + size - olen; - if (len != size) - ralerr: - scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what); - if ((nm <= scm_mtrigger)) - { - SCM_SYSCALL (ptr = (char *) realloc (where, size)); - if (NULL != ptr) - { - scm_mallocated = nm; - return ptr; - } - } - scm_igc (what); - nm = scm_mallocated + size - olen; - SCM_SYSCALL (ptr = (char *) realloc (where, size)); - if (NULL != ptr) - { - scm_mallocated = nm; - if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { - if (nm > scm_mtrigger) - scm_mtrigger = nm + nm / 2; - else - scm_mtrigger += scm_mtrigger / 2; - } - return ptr; - } - goto ralerr; -} - -void -scm_must_free (obj) - char *obj; -{ - if (obj) - free (obj); - else - scm_wta (SCM_INUM0, "already free", ""); -} - - - - -/* {Heap Segments} - * - * Each heap segment is an array of objects of a particular size. - * Every segment has an associated (possibly shared) freelist. - * A table of segment records is kept that records the upper and - * lower extents of the segment; this is used during the conservative - * phase of gc to identify probably gc roots (because they point - * into valid segments at reasonable offsets). - */ - -/* scm_expmem - * is true if the first segment was smaller than INIT_HEAP_SEG. - * If scm_expmem is set to one, subsequent segment allocations will - * allocate segments of size SCM_EXPHEAP(scm_heap_size). - */ -int scm_expmem = 0; - -/* scm_heap_org - * is the lowest base address of any heap segment. - */ -SCM_CELLPTR scm_heap_org; - -struct scm_heap_seg_data * scm_heap_table = 0; -int scm_n_heap_segs = 0; - -/* scm_heap_size - * is the total number of cells in heap segments. - */ -long scm_heap_size = 0; - -/* init_heap_seg - * initializes a new heap segment and return the number of objects it contains. - * - * The segment origin, segment size in bytes, and the span of objects - * in cells are input parameters. The freelist is both input and output. - * - * This function presume that the scm_heap_table has already been expanded - * to accomodate a new segment record. - */ - - -static scm_sizet -init_heap_seg (seg_org, size, ncells, freelistp) - SCM_CELLPTR seg_org; - scm_sizet size; - int ncells; - SCM *freelistp; -{ - register SCM_CELLPTR ptr; -#ifdef SCM_POINTERS_MUNGED - register SCM scmptr; -#else -#undef scmptr -#define scmptr ptr -#endif - SCM_CELLPTR seg_end; - scm_sizet new_seg_index; - scm_sizet n_new_objects; - - if (seg_org == NULL) - return 0; - - ptr = seg_org; - - /* Compute the ceiling on valid object pointers w/in this segment. - */ - seg_end = CELL_DN ((char *) ptr + size); - - /* Find the right place and insert the segment record. - * - */ - for (new_seg_index = 0; - ( (new_seg_index < scm_n_heap_segs) - && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org)); - new_seg_index++) - ; - - { - int i; - for (i = scm_n_heap_segs; i > new_seg_index; --i) - scm_heap_table[i] = scm_heap_table[i - 1]; - } - - ++scm_n_heap_segs; - - scm_heap_table[new_seg_index].valid = 0; - scm_heap_table[new_seg_index].ncells = ncells; - scm_heap_table[new_seg_index].freelistp = freelistp; - scm_heap_table[new_seg_index].bounds[0] = (SCM_CELLPTR)ptr; - scm_heap_table[new_seg_index].bounds[1] = (SCM_CELLPTR)seg_end; - - - /* Compute the least valid object pointer w/in this segment - */ - ptr = CELL_UP (ptr); - - - n_new_objects = seg_end - ptr; - - /* Prepend objects in this segment to the freelist. - */ - while (ptr < seg_end) - { -#ifdef SCM_POINTERS_MUNGED - scmptr = PTR2SCM (ptr); -#endif - SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell); - SCM_SETCDR (scmptr, PTR2SCM (ptr + ncells)); - ptr += ncells; - } - - ptr -= ncells; - - /* Patch up the last freelist pointer in the segment - * to join it to the input freelist. - */ - SCM_SETCDR (PTR2SCM (ptr), *freelistp); - *freelistp = PTR2SCM (CELL_UP (seg_org)); - - scm_heap_size += (ncells * n_new_objects); - return size; -#ifdef scmptr -#undef scmptr -#endif -} - - -static void -alloc_some_heap (ncells, freelistp) - int ncells; - SCM * freelistp; -{ - struct scm_heap_seg_data * tmptable; - SCM_CELLPTR ptr; - scm_sizet len; - - /* Critical code sections (such as the garbage collector) - * aren't supposed to add heap segments. - */ - if (scm_gc_heap_lock) - scm_wta (SCM_UNDEFINED, "need larger initial", "heap"); - - /* Expand the heap tables to have room for the new segment. - * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg - * only if the allocation of the segment itself succeeds. - */ - len = (1 + scm_n_heap_segs) * sizeof (struct scm_heap_seg_data); - - SCM_SYSCALL (tmptable = ((struct scm_heap_seg_data *) - realloc ((char *)scm_heap_table, len))); - if (!tmptable) - scm_wta (SCM_UNDEFINED, "could not grow", "hplims"); - else - scm_heap_table = tmptable; - - - /* Pick a size for the new heap segment. - * The rule for picking the size of a segment is explained in - * gc.h - */ - if (scm_expmem) - { - len = (scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell)); - if ((scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell)) != len) - len = 0; - } - else - len = SCM_HEAP_SEG_SIZE; - - { - scm_sizet smallest; - - smallest = (ncells * sizeof (scm_cell)); - if (len < smallest) - len = (ncells * sizeof (scm_cell)); - - /* Allocate with decaying ambition. */ - while ((len >= SCM_MIN_HEAP_SEG_SIZE) - && (len >= smallest)) - { - SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (len)); - if (ptr) - { - init_heap_seg (ptr, len, ncells, freelistp); - return; - } - len /= 2; - } - } - - scm_wta (SCM_UNDEFINED, "could not grow", "heap"); -} - - - -SCM_PROC (s_unhash_name, "unhash-name", 1, 0, 0, scm_unhash_name); -SCM -scm_unhash_name (name) - SCM name; -{ - int x; - int bound; - SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_unhash_name); - SCM_DEFER_INTS; - bound = scm_n_heap_segs; - for (x = 0; x < bound; ++x) - { - SCM_CELLPTR p; - SCM_CELLPTR pbound; - p = (SCM_CELLPTR)scm_heap_table[x].bounds[0]; - pbound = (SCM_CELLPTR)scm_heap_table[x].bounds[1]; - while (p < pbound) - { - SCM incar; - incar = p->car; - if (1 == (7 & (int)incar)) - { - --incar; - if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name)) - && (SCM_CDR (incar) != 0) - && (SCM_CDR (incar) != 1)) - { - p->car = name; - } - } - ++p; - } - } - SCM_ALLOW_INTS; - return name; -} - - - -/* {GC Protection Helper Functions} - */ - - -void -scm_remember (ptr) - SCM * ptr; -{} - - -#ifdef __STDC__ -SCM -scm_return_first (SCM elt, ...) -#else -SCM -scm_return_first (elt, va_alist) - SCM elt; - va_dcl -#endif -{ - return elt; -} - - -SCM -scm_permanent_object (obj) - SCM obj; -{ - SCM_REDEFER_INTS; - scm_permobjs = scm_cons (obj, scm_permobjs); - SCM_REALLOW_INTS; - return obj; -} - - - -int -scm_init_storage (init_heap_size) - long init_heap_size; -{ - scm_sizet j; - - j = SCM_NUM_PROTECTS; - while (j) - scm_sys_protects[--j] = SCM_BOOL_F; - scm_block_gc = 1; - scm_freelist = SCM_EOL; - scm_expmem = 0; - - j = SCM_HEAP_SEG_SIZE; - scm_mtrigger = SCM_INIT_MALLOC_LIMIT; - scm_heap_table = ((struct scm_heap_seg_data *) - scm_must_malloc (sizeof (struct scm_heap_seg_data), "hplims")); - if (0L == init_heap_size) - init_heap_size = SCM_INIT_HEAP_SIZE; - j = init_heap_size; - if ((init_heap_size != j) - || !init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist)) - { - j = SCM_HEAP_SEG_SIZE; - if (!init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist)) - return 1; - } - else - scm_expmem = 1; - scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0]); - /* scm_hplims[0] can change. do not remove scm_heap_org */ - if (!(scm_weak_vectors = (SCM *) malloc ((scm_weak_size = 32) * sizeof(SCM *)))) - return 1; - - /* Initialise the list of ports. */ - scm_port_table = (struct scm_port_table **) malloc ((long) (sizeof (struct scm_port_table) - * scm_port_table_room)); - if (!scm_port_table) - return 1; - - - scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL); - SCM_SETCDR (scm_undefineds, scm_undefineds); - - scm_listofnull = scm_cons (SCM_EOL, SCM_EOL); - scm_nullstr = scm_makstr (0L, 0); - scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED, SCM_UNDEFINED); - scm_symhash = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED); - scm_weak_symhash = scm_make_weak_key_hash_table ((SCM) SCM_MAKINUM (scm_symhash_dim)); - scm_symhash_vars = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED); - scm_stand_in_procs = SCM_EOL; - scm_permobjs = SCM_EOL; - scm_asyncs = SCM_EOL; - scm_sysintern ("most-positive-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM)); - scm_sysintern ("most-negative-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM)); -#ifdef SCM_BIGDIG - scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD)); -#endif - return 0; -} - - -void -scm_init_gc () -{ -#include "gc.x" -} diff --git a/libguile/gc.h b/libguile/gc.h deleted file mode 100644 index 0a1f20549..000000000 --- a/libguile/gc.h +++ /dev/null @@ -1,101 +0,0 @@ -/* classes: h_files */ - -#ifndef GCH -#define GCH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -#define SCM_FREEP(x) (SCM_CAR(x)==scm_tc_free_cell) -#define SCM_NFREEP(x) (!SCM_FREEP(x)) - -extern struct scm_heap_seg_data *scm_heap_table; -extern int scm_n_heap_segs; -extern int scm_take_stdin; -extern int scm_block_gc; -extern int scm_gc_heap_lock; - - - -extern long scm_heap_size; -extern SCM_CELLPTR scm_heap_org; -extern SCM scm_freelist; -extern unsigned long scm_gc_cells_collected; -extern unsigned long scm_gc_malloc_collected; -extern unsigned long scm_gc_ports_collected; -extern unsigned long scm_cells_allocated; -extern unsigned long scm_mallocated; -extern long scm_mtrigger; - -#ifdef DEBUG_FREELIST -extern void scm_debug_newcell SCM_P ((SCM *into)); -#endif - - - -extern SCM scm_object_addr SCM_P ((SCM obj)); -extern SCM scm_unhash_name SCM_P ((SCM name)); -extern SCM scm_gc_stats SCM_P ((void)); -extern void scm_gc_start SCM_P ((char *what)); -extern void scm_gc_end SCM_P ((void)); -extern SCM scm_gc SCM_P ((void)); -extern void scm_gc_for_alloc SCM_P ((int ncells, SCM * freelistp)); -extern SCM scm_gc_for_newcell SCM_P ((void)); -extern void scm_igc SCM_P ((char *what)); -extern void scm_gc_mark SCM_P ((SCM p)); -extern void scm_mark_locations SCM_P ((SCM_STACKITEM x[], scm_sizet n)); -extern int scm_cellp SCM_P ((SCM value)); -extern void scm_gc_sweep SCM_P ((void)); -extern char * scm_must_malloc SCM_P ((long len, char *what)); -extern char * scm_must_realloc SCM_P ((char *where, long olen, long len, - char *what)); -extern void scm_must_free SCM_P ((char *obj)); -extern void scm_remember SCM_P ((SCM * ptr)); -extern SCM scm_return_first SCM_P ((SCM elt, ...)); -extern SCM scm_permanent_object SCM_P ((SCM obj)); -extern SCM scm_protect_object SCM_P ((SCM obj)); -extern SCM scm_unprotect_object SCM_P ((SCM obj)); -extern int scm_init_storage SCM_P ((long init_heap_size)); -extern void scm_init_gc SCM_P ((void)); -#endif /* GCH */ diff --git a/libguile/gdb_interface.h b/libguile/gdb_interface.h deleted file mode 100644 index dd8aac3d9..000000000 --- a/libguile/gdb_interface.h +++ /dev/null @@ -1,127 +0,0 @@ -/* Simple interpreter interface for GDB, the GNU debugger. - Copyright (C) 1996 Mikael Djurfeldt. - -This file is part of GDB. - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -The author can be reached at djurfeldt@nada.kth.se -Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ - -#ifndef GDB_INTERFACE_H -#define GDB_INTERFACE_H - -/* This is the header file for GDB's interpreter interface. The - interpreter must supply definitions of all symbols declared in this - file. - - Before including this file, you must #define GDB_TYPE to be the - data type used for communication with the interpreter. */ - -/* The following macro can be used to anchor the symbols of the - interface in your main program. This is necessary if the interface - is defined in a library, such as Guile. */ - -#define GDB_INTERFACE \ -void *gdb_interface[] = { \ - &gdb_options, \ - &gdb_language, \ - &gdb_result, \ - &gdb_output, \ - &gdb_output_length, \ - gdb_maybe_valid_type_p, \ - gdb_read, \ - gdb_eval, \ - gdb_print, \ - gdb_binding \ -}; \ - - -/* GDB_OPTIONS is a set of flags informing gdb what features are present - in the interface. Currently only one option is supported: */ - -/* GDB_HAVE_BINDINGS: Set this bit if your interpreter can create new - top level bindings on demand (through gdb_top_level_binding) */ - -#define GDB_HAVE_BINDINGS 1 - -extern unsigned short gdb_options; - -/* GDB_LANGUAGE holds the name of the preferred language mode for this - interpreter. For lisp interpreters, the suggested mode is "lisp/c". */ - -extern char *gdb_language; - -/* GDB_RESULT is used for passing results from the interpreter to GDB */ - -extern GDB_TYPE gdb_result; - -/* The interpreter passes strings to GDB in GDB_OUTPUT and - GDB_OUTPUT_LENGTH. GDB_OUTPUT should hold the pointer to the - string. GDB_OUTPUT_LENGTH should hold its length. The string - doesn't need to be terminated by '\0'. */ - -extern char *gdb_output; - -extern int gdb_output_length; - -/* Return TRUE if the interpreter regards VALUE's type as valid. A - lazy implementation is allowed to pass TRUE always. FALSE should - only be returned when it is certain that VALUE is not valid. - - In the "lisp/c" language mode, this is used to heuristically - discriminate lisp values from C values during printing. */ - -extern int gdb_maybe_valid_type_p SCM_P ((GDB_TYPE value)); - -/* Parse expression in string STR. Store result in GDB_RESULT, then - return 0 to indicate success. On error, return -1 to indicate - failure. An error string can be passed in GDB_OUTPUT and - GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero if - no message is passed. Please note that the resulting value should - be protected against garbage collection. */ - -extern int gdb_read SCM_P ((char *str)); - -/* Evaluate expression EXP. Store result in GDB_RESULT, then return 0 - to indicate success. On error, return -1 to indicate failure. Any - output (both on success and failure) can be passed in GDB_OUTPUT - and GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero - if no output is passed. Please note that the resulting lisp object - should be protected against garbage collection. */ - -extern int gdb_eval SCM_P ((GDB_TYPE exp)); - -/* Print VALUE. Store output in GDB_OUTPUT and GDB_OUTPUT_LENGTH. - Return 0 to indicate success. On error, return -1 to indicate - failure. GDB will not look at GDB_OUTPUT or GDB_OUTPUT_LENGTH on - failure. Note that this function should be robust against strange - values. It could in fact be passed any kind of value. */ - -extern int gdb_print SCM_P ((GDB_TYPE value)); - -/* Bind NAME to VALUE in interpreter. (GDB has previously obtained - NAME by passing a string to gdb_read.) Return 0 to indicate - success or -1 to indicate failure. This feature is optional. GDB - will only call this function if the GDB_HAVE_BINDINGS flag is set - in gdb_options. Note that GDB may call this function many times - for the same name. - - For scheme interpreters, this function should introduce top-level - bindings. */ - -extern int gdb_binding SCM_P ((GDB_TYPE name, GDB_TYPE value)); - -#endif /* GDB_INTERFACE_H */ diff --git a/libguile/gdbint.c b/libguile/gdbint.c deleted file mode 100644 index 3ce4f2eca..000000000 --- a/libguile/gdbint.c +++ /dev/null @@ -1,325 +0,0 @@ -/* GDB interface for Guile - * Copyright (C) 1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - -#include <stdio.h> -#include "_scm.h" -#include "tag.h" -#include "strports.h" -#include "read.h" -#include "eval.h" -#include "chars.h" - -#include "gdbint.h" - -/* {Support for debugging with gdb} - * - * TODO: - * - * 1. Redirect outputs - * 2. Catch errors - * 3. Prevent print from causing segmentation fault when given broken pairs - */ - -#include <stdio.h> -#include "_scm.h" - -#define GDB_TYPE SCM - -#include "gdb_interface.h" - - - -/* Be carefull when this macro is true. - scm_gc_heap_lock is set during gc. - */ -#define SCM_GC_P (scm_gc_heap_lock) - -/* Macros that encapsulate blocks of code which can be called by the - * debugger. - */ -#define SCM_BEGIN_FOREIGN_BLOCK \ -{ \ - old_ints = scm_ints_disabled; scm_ints_disabled = 1; \ - old_gc = scm_block_gc; scm_block_gc = 1; \ - scm_print_carefully_p = 1; \ -} \ - - -#define SCM_END_FOREIGN_BLOCK \ -{ \ - scm_print_carefully_p = 0; \ - scm_block_gc = old_gc; \ - scm_ints_disabled = old_ints; \ -} \ - - -#define RESET_STRING { gdb_output_length = 0; } - -#define SEND_STRING(str) \ -{ \ - gdb_output = str; \ - gdb_output_length = strlen (str); \ -} \ - - -/* {Gdb interface} - */ - -unsigned short gdb_options = GDB_HAVE_BINDINGS; - -char *gdb_language = "lisp/c"; - -SCM gdb_result; - -char *gdb_output; - -int gdb_output_length; - -int scm_print_carefully_p; - -static SCM gdb_input_port; -static int port_mark_p, stream_mark_p, string_mark_p; - -static SCM tok_buf; -static int tok_buf_mark_p; - -static SCM gdb_output_port; -static int old_ints, old_gc; - - -static void unmark_port SCM_P ((SCM port)); - -static void -unmark_port (port) - SCM port; -{ - SCM stream, string; - port_mark_p = SCM_GC8MARKP (port); - SCM_CLRGC8MARK (port); - stream = SCM_STREAM (port); - stream_mark_p = SCM_GCMARKP (stream); - SCM_CLRGCMARK (stream); - string = SCM_CDR (stream); - string_mark_p = SCM_GC8MARKP (string); - SCM_CLRGC8MARK (string); -} - - -static void remark_port SCM_P ((SCM port)); - -static void -remark_port (port) - SCM port; -{ - SCM stream = SCM_STREAM (port); - SCM string = SCM_CDR (stream); - if (string_mark_p) SCM_SETGC8MARK (string); - if (stream_mark_p) SCM_SETGCMARK (stream); - if (port_mark_p) SCM_SETGC8MARK (port); -} - - -int -gdb_maybe_valid_type_p (value) - SCM value; -{ - if (SCM_IMP (value) || scm_cellp (value)) - return scm_tag (value) != SCM_MAKINUM (-1); - return 0; -} - - -int -gdb_read (str) - char *str; -{ - SCM ans; - int status = 0; - RESET_STRING; - /* Need to be restrictive about what to read? */ - if (SCM_GC_P) - { - char *p; - for (p = str; *p != '\0'; ++p) - switch (*p) - { - case '(': - case '\'': - case '"': - SEND_STRING ("Can't read this kind of expressions during gc"); - return -1; - case '#': - if (*++p == '\0') - goto premature; - if (*p == '\\') - { - if (*++p != '\0') - continue; - premature: - SEND_STRING ("Premature end of lisp expression"); - return -1; - } - default: - continue; - } - } - SCM_BEGIN_FOREIGN_BLOCK; - unmark_port (gdb_input_port); - /* Replace string in input port and reset stream */ - ans = SCM_CDR (SCM_STREAM (gdb_input_port)); - SCM_SETCHARS (ans, str); - SCM_SETLENGTH (ans, strlen (str), scm_tc7_string); - SCM_SETCAR (SCM_STREAM (gdb_input_port), SCM_INUM0); - /* Read one object */ - tok_buf_mark_p = SCM_GC8MARKP (tok_buf); - SCM_CLRGC8MARK (tok_buf); - ans = scm_lreadr (&tok_buf, gdb_input_port, 0, SCM_BOOL_F, &ans); - if (SCM_GC_P) - { - if (SCM_NIMP (ans)) - { - SEND_STRING ("Non-immediate created during gc. Memory may be trashed."); - status = -1; - goto exit; - } - } - gdb_result = ans; - /* Protect answer from future GC */ - if (SCM_NIMP (ans)) - scm_permanent_object (ans); -exit: - if (tok_buf_mark_p) - SCM_SETGC8MARK (tok_buf); - remark_port (gdb_input_port); - SCM_END_FOREIGN_BLOCK; - return status; -} - - -int -gdb_eval (exp) - SCM exp; -{ - RESET_STRING; - if (SCM_IMP (exp)) - { - gdb_result = exp; - return 0; - } - if (SCM_GC_P) - { - SEND_STRING ("Can't evaluate lisp expressions during gc"); - return -1; - } - SCM_BEGIN_FOREIGN_BLOCK; - { - SCM env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var)); - gdb_result = scm_permanent_object (scm_ceval (exp, env)); - } - SCM_END_FOREIGN_BLOCK; - return 0; -} - - -int -gdb_print (obj) - SCM obj; -{ - RESET_STRING; - SCM_BEGIN_FOREIGN_BLOCK; - /* Reset stream */ - SCM_SETCAR (SCM_STREAM (gdb_output_port), SCM_INUM0); - scm_write (obj, gdb_output_port); - scm_display (SCM_MAKICHR (0), gdb_output_port); - SEND_STRING (SCM_CHARS (SCM_CDR (SCM_STREAM (gdb_output_port)))); - SCM_END_FOREIGN_BLOCK; - return 0; -} - - -int -gdb_binding (name, value) - SCM name; - SCM value; -{ - RESET_STRING; - if (SCM_GC_P) - { - SEND_STRING ("Can't create new bindings during gc"); - return -1; - } - SCM_BEGIN_FOREIGN_BLOCK; - { - SCM vcell = scm_sym2vcell (name, - SCM_CDR (scm_top_level_lookup_closure_var), - SCM_BOOL_T); - SCM_SETCDR (vcell, value); - } - SCM_END_FOREIGN_BLOCK; - return 0; -} - -void -scm_init_gdbint () -{ - static char *s = "scm_init_gdb_interface"; - SCM port; - - scm_print_carefully_p = 0; - - port = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_MAKINUM (80), SCM_UNDEFINED), - SCM_OPN | SCM_WRTNG, - s); - gdb_output_port = scm_permanent_object (port); - - port = scm_mkstrport (SCM_INUM0, - scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED), - SCM_OPN | SCM_RDNG, - s); - gdb_input_port = scm_permanent_object (port); - - tok_buf = scm_permanent_object (scm_makstr (30L, 0)); -} diff --git a/libguile/gdbint.h b/libguile/gdbint.h deleted file mode 100644 index bf12524f6..000000000 --- a/libguile/gdbint.h +++ /dev/null @@ -1,58 +0,0 @@ -/* classes: h_files */ - -#ifndef GDBINTH -#define GDBINTH -/* Copyright (C) 1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include "libguile/__scm.h" - - - -extern int scm_print_carefully_p; - -extern void scm_init_gdbint SCM_P ((void)); - -#endif /* GDBINTH */ diff --git a/libguile/genio.c b/libguile/genio.c deleted file mode 100644 index 5ebd86e3f..000000000 --- a/libguile/genio.c +++ /dev/null @@ -1,508 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "extchrs.h" -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "genio.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - - -static void scm_putc SCM_P ((int c, SCM port)); - -static void -scm_putc (c, port) - int c; - SCM port; -{ - scm_sizet i = SCM_PTOBNUM (port); - SCM_SYSCALL ((scm_ptobs[i].fputc) (c, SCM_STREAM (port))); -} - - - -static void scm_puts SCM_P ((char *s, SCM port)); - -static void -scm_puts (s, port) - char *s; - SCM port; -{ - scm_sizet i = SCM_PTOBNUM (port); - SCM_SYSCALL ((scm_ptobs[i].fputs) (s, SCM_STREAM (port))); -#ifdef TRANSCRIPT_SUPPORT - if (scm_trans && (port == def_outp || port == cur_errp)) - SCM_SYSCALL (fputs (s, scm_trans)); -#endif -} - - - -static int scm_lfwrite SCM_P ((char *ptr, scm_sizet size, scm_sizet nitems, SCM port)); - -static int -scm_lfwrite (ptr, size, nitems, port) - char *ptr; - scm_sizet size; - scm_sizet nitems; - SCM port; -{ - int ret; - scm_sizet i = SCM_PTOBNUM (port); - SCM_SYSCALL (ret = (scm_ptobs[i].fwrite(ptr, size, nitems, SCM_STREAM (port)))); -#ifdef TRANSCRIPT_SUPPORT - if (scm_trans && (port == def_outp || port == cur_errp)) - SCM_SYSCALL (fwrite (ptr, size, nitems, scm_trans)); -#endif - return ret; -} - - - - - -void -scm_gen_putc (c, port) - int c; - SCM port; -{ - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - { - /* Nothing good to do with extended chars here... - * just truncate them. - */ - scm_putc ((unsigned char)c, port); - break; - } - - case scm_mb_port: - { - char buf[256]; - int len; - - SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_MAKICHR (c), - "huge translation", "scm_gen_putc"); - - len = xwctomb (buf, c); - - SCM_ASSERT ((len >= 0), SCM_MAKICHR (c), "bogus character", "scm_gen_putc"); - - if (len == 0) - scm_putc (0, port); - else - { - int x; - for (x = 0; x < len; ++x) - scm_putc (buf[x], port); - } - break; - } - - case scm_wchar_port: - { - scm_putc (((unsigned char)(c >> 8) & 0xff), port); - scm_putc ((unsigned char)(c & 0xff), port); - break; - } - } -} - - - - - - -void -scm_gen_puts (rep, str_data, port) - enum scm_string_representation_type rep; - char *str_data; - SCM port; -{ - switch (rep) - { - - case scm_regular_string: - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - case scm_mb_port: - scm_puts (str_data, port); - return; - case scm_wchar_port: - { - while (*str_data) - { - scm_putc (0, port); - scm_putc (*str_data, port); - ++str_data; - } - return; - } - } - - case scm_mb_string: - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - case scm_mb_port: - scm_puts (str_data, port); - return; - case scm_wchar_port: - { - xwchar_t output; - int len; - int size; - - size = strlen (str_data); - while (size) - { - len = xmbtowc (&output, str_data, size); - SCM_ASSERT ((len > 0), SCM_MAKINUM (*str_data), "bogus character", "scm_gen_puts"); - scm_putc ((output >> 8) & 0xff, port); - scm_putc (output & 0xff, port); - size -= len; - str_data += len; - } - return; - } - } - - case scm_wchar_string: - { - xwchar_t * wstr_data; - - wstr_data = (xwchar_t *) str_data; - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - while (*wstr_data) - { - scm_putc ((unsigned char) *wstr_data, port); - ++wstr_data; - } - return; - - case scm_mb_port: - { - char buf[256]; - SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F, - "huge translation", "scm_gen_puts"); - - while (*wstr_data) - { - int len; - - len = xwctomb (buf, *wstr_data); - - SCM_ASSERT ((len > 0), SCM_MAKINUM (*wstr_data), "bogus character", "scm_gen_puts"); - - { - int x; - for (x = 0; x < len; ++x) - scm_putc (buf[x], port); - } - ++wstr_data; - } - return; - } - - case scm_wchar_port: - { - int len; - for (len = 0; wstr_data[len]; ++len) - ; - scm_lfwrite (str_data, sizeof (xwchar_t), len, port); - return; - } - } - } - } -} - - - - - -void -scm_gen_write (rep, str_data, nitems, port) - enum scm_string_representation_type rep; - char *str_data; - scm_sizet nitems; - SCM port; -{ - /* is nitems bytes or characters in the mb_string case? */ - - switch (rep) - { - case scm_regular_string: - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - case scm_mb_port: - scm_lfwrite (str_data, 1, nitems, port); - return; - case scm_wchar_port: - { - while (nitems) - { - scm_putc (0, port); - scm_putc (*str_data, port); - ++str_data; - --nitems; - } - return; - } - } - - case scm_mb_string: - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - case scm_mb_port: - scm_lfwrite (str_data, 1, nitems, port); - return; - - case scm_wchar_port: - { - xwchar_t output; - int len; - - while (nitems) - { - len = xmbtowc (&output, str_data, nitems); - SCM_ASSERT ((len > 0), SCM_MAKINUM (*str_data), "bogus character", "scm_gen_puts"); - scm_putc ((output >> 8) & 0xff, port); - scm_putc (output & 0xff, port); - nitems -= len; - str_data += len; - } - return; - } - } - - case scm_wchar_string: - { - xwchar_t * wstr_data; - - wstr_data = (xwchar_t *) str_data; - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - while (nitems) - { - scm_putc ((unsigned char) *wstr_data, port); - ++wstr_data; - --nitems; - } - return; - - case scm_mb_port: - { - char buf[256]; - SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F, - "huge translation", "scm_gen_puts"); - - while (nitems) - { - int len; - - len = xwctomb (buf, *wstr_data); - - SCM_ASSERT ((len > 0), SCM_MAKINUM (*wstr_data), "bogus character", "scm_gen_puts"); - - { - int x; - for (x = 0; x < len; ++x) - scm_putc (buf[x], port); - } - ++wstr_data; - --nitems; - } - return; - } - - case scm_wchar_port: - { - scm_lfwrite (str_data, sizeof (xwchar_t), nitems, port); - return; - } - } - } - } -} - - - - - -static int scm_getc SCM_P ((SCM port)); - -static int -scm_getc (port) - SCM port; -{ - SCM f; - int c; - scm_sizet i; - - f = SCM_STREAM (port); - i = SCM_PTOBNUM (port); - SCM_SYSCALL (c = (scm_ptobs[i].fgetc) (f)); - return c; -} - - -int -scm_gen_getc (port) - SCM port; -{ - int c; - - /* One char may be stored in the high bits of (car port) orre@nada.kth.se. */ - if (SCM_CRDYP (port)) - { - c = SCM_CGETUN (port); - SCM_CLRDY (port); /* Clear ungetted char */ - - return_c: - if (c == '\n') - { - SCM_INCLINE (port); - } - else if (c == '\t') - { - SCM_TABCOL (port); - } - else - { - SCM_INCCOL (port); - } - return c; - } - - - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - c = scm_getc (port); - goto return_c; - - case scm_mb_port: - { - int x; - unsigned char buf[256]; - - SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F, - "huge translation", "scm_gen_puts"); - - x = 0; - while (1) - { - xwchar_t out; - c = scm_getc (port); - - if (c == EOF) - return EOF; - - buf[x] = c; - - if (xmbtowc (&out, buf, x + 1) > 0) - { - c = out; - goto return_c; - } - - SCM_ASSERT (x < sizeof (buf), SCM_BOOL_F, - "huge translation", "scm_gen_getc"); - ++x; - } - } - - - case scm_wchar_port: - { - int hi; - int lo; - hi = scm_getc (port); - lo = (hi == EOF - ? EOF - : scm_getc (port)); - c = ((hi == EOF) - ? EOF - : ((hi << 8) | lo)); - goto return_c; - } - - - default: - return EOF; - } -} - - -void -scm_gen_ungetc (c, port) - int c; - SCM port; -{ -/* SCM_ASSERT(!SCM_CRDYP(port), port, SCM_ARG2, "too many scm_gen_ungetc");*/ - SCM_CUNGET (c, port); - if (c == '\n') - { - /* What should col be in this case? - * We'll leave it at -1. - */ - SCM_LINUM (port) -= 1; - } - else - SCM_COL(port) -= 1; -} - - diff --git a/libguile/genio.h b/libguile/genio.h deleted file mode 100644 index 78d17fac5..000000000 --- a/libguile/genio.h +++ /dev/null @@ -1,59 +0,0 @@ -/* classes: h_files */ - -#ifndef GENIOH -#define GENIOH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern void scm_gen_putc SCM_P ((int c, SCM port)); -extern void scm_gen_puts SCM_P ((enum scm_string_representation_type rep, - char *str_data, - SCM port)); -extern void scm_gen_write SCM_P ((enum scm_string_representation_type rep, char *str_data, scm_sizet nitems, SCM port)); -extern int scm_gen_getc SCM_P ((SCM port)); -extern void scm_gen_ungetc SCM_P ((int c, SCM port)); - -#endif /* GENIOH */ diff --git a/libguile/gscm.c b/libguile/gscm.c deleted file mode 100644 index daf172730..000000000 --- a/libguile/gscm.c +++ /dev/null @@ -1,594 +0,0 @@ -/* Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - - - -#include <stdio.h> -#include <sys/param.h> -#include "gscm.h" -#include "_scm.h" - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - -extern char *getenv (); - - -/* {Top Level Evaluation} - * - * Top level evaluation has to establish a dynamic root context, - * enable Scheme signal handlers, and catch global escapes (errors, quits, - * aborts, restarts, and execs) from the interpreter. - */ - - -/* {Printing Objects to Strings} - */ - - -static GSCM_status gscm_portprint_obj SCM_P ((SCM port, SCM obj)); - -static GSCM_status -gscm_portprint_obj (port, obj) - SCM port; - SCM obj; -{ - scm_prin1 (obj, port, 1); - return GSCM_OK; -} - - -struct seval_str_frame -{ - GSCM_status status; - SCM * answer; - GSCM_top_level top; - char * str; -}; - - -static void _seval_str_fn SCM_P ((void * vframe)); - -static void -_seval_str_fn (vframe) - void * vframe; -{ - struct seval_str_frame * frame; - frame = (struct seval_str_frame *)vframe; - frame->status = gscm_seval_str (frame->answer, frame->top, frame->str); -} - - - - -static GSCM_status gscm_strprint_obj SCM_P ((SCM * answer, SCM obj)); - -static GSCM_status -gscm_strprint_obj (answer, obj) - SCM * answer; - SCM obj; -{ - SCM str; - SCM port; - GSCM_status stat; - str = scm_makstr (64, 0); - port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "gscm_strprint_obj"); - stat = gscm_portprint_obj (port, obj); - if (stat == GSCM_OK) - *answer = str; - else - *answer = SCM_BOOL_F; - return stat; -} - - -static GSCM_status gscm_cstr SCM_P ((char ** answer, SCM obj)); - -static GSCM_status -gscm_cstr (answer, obj) - char ** answer; - SCM obj; -{ - GSCM_status stat; - - *answer = (char *)malloc (SCM_LENGTH (obj)); - stat = GSCM_OK; - if (!*answer) - stat = GSCM_OUT_OF_MEM; - else - memcpy (*answer, SCM_CHARS (obj), SCM_LENGTH (obj)); - return stat; -} - - -/* {Invoking The Interpreter} - */ - - -static SCM gscm_silent_repl SCM_P ((SCM env)); - -static SCM -gscm_silent_repl (env) - SCM env; -{ - SCM source; - SCM answer; - answer = SCM_UNSPECIFIED; - while ((source = scm_read (SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED)) != SCM_EOF_VAL) - answer = scm_eval_x (source); - return answer; -} - - -#ifdef _UNICOS -typedef int setjmp_type; -#else -typedef long setjmp_type; -#endif - - -static GSCM_status _eval_port SCM_P ((SCM * answer, GSCM_top_level toplvl, SCM port, int printp)); - -static GSCM_status -_eval_port (answer, toplvl, port, printp) - SCM * answer; - GSCM_top_level toplvl; - SCM port; - int printp; -{ - SCM saved_inp; - GSCM_status status; - setjmp_type i; - static int deja_vu = 0; - SCM ignored; - - if (deja_vu) - return GSCM_ILLEGALLY_REENTERED; - - ++deja_vu; - /* Take over signal handlers for all the interesting signals. - */ - scm_init_signals (); - - - /* Default return values: - */ - if (!answer) - answer = &ignored; - status = GSCM_OK; - *answer = SCM_BOOL_F; - - /* Perform evalutation under a new dynamic root. - * - */ - SCM_BASE (scm_rootcont) = (SCM_STACKITEM *) & i; -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0; -#endif - saved_inp = scm_cur_inp; - i = setjmp (SCM_JMPBUF (scm_rootcont)); -#ifdef STACK_CHECKING - scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; -#endif - if (!i) - { - scm_gc_heap_lock = 0; - scm_ints_disabled = 0; - /* need to close loading files here. */ - scm_cur_inp = port; - { - SCM top_env; - top_env = SCM_EOL; - *answer = gscm_silent_repl (top_env); - } - scm_cur_inp = saved_inp; - if (printp) - status = gscm_strprint_obj (answer, *answer); - } - else - { - scm_cur_inp = saved_inp; - *answer = scm_exitval; - if (printp) - gscm_strprint_obj (answer, *answer); - status = GSCM_ERROR; - } - - scm_gc_heap_lock = 1; - scm_ints_disabled = 1; - scm_restore_signals (); - --deja_vu; - return status; -} - - -static GSCM_status seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str)); - -static GSCM_status -seval_str (answer, toplvl, str) - SCM *answer; - GSCM_top_level toplvl; - char * str; -{ - SCM scheme_str; - SCM port; - GSCM_status status; - - scheme_str = scm_makfromstr (str, strlen (str), 0); - port = scm_mkstrport (SCM_MAKINUM (0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_seval_str"); - status = _eval_port (answer, toplvl, port, 0); - return status; -} - - - -GSCM_status -gscm_seval_str (answer, toplvl, str) - SCM *answer; - GSCM_top_level toplvl; - char * str; -{ - SCM_STACKITEM i; - GSCM_status status; - scm_stack_base = &i; - status = seval_str (answer, toplvl, str); - scm_stack_base = 0; - return status; -} - - -void -format_load_command (buf, file_name) - char * buf; - char *file_name; -{ - char quoted_name[MAXPATHLEN + 1]; - int source; - int dest; - - for (source = dest = 0; file_name[source]; ++source) - { - if (file_name[source] == '"') - quoted_name[dest++] = '\\'; - quoted_name[dest++] = file_name[source]; - } - quoted_name[dest] = 0; - sprintf (buf, "(%%try-load \"%s\")", quoted_name); -} - - -GSCM_status -gscm_seval_file (answer, toplvl, file_name) - SCM *answer; - GSCM_top_level toplvl; - char * file_name; -{ - char command[MAXPATHLEN * 3]; - format_load_command (command, file_name); - return gscm_seval_str (answer, toplvl, command); -} - - - -static GSCM_status eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str)); - -static GSCM_status -eval_str (answer, toplvl, str) - char ** answer; - GSCM_top_level toplvl; - char * str; -{ - SCM sanswer; - SCM scheme_str; - SCM port; - GSCM_status status; - - scheme_str = scm_makfromstr (str, strlen (str), 0); - port = scm_mkstrport (SCM_MAKINUM(0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_eval_str"); - status = _eval_port (&sanswer, toplvl, port, 1); - if (answer) - { - if (status == GSCM_OK) - status = gscm_cstr (answer, sanswer); - else - *answer = 0; - } - return status; -} - - - -GSCM_status -gscm_eval_str (answer, toplvl, str) - char ** answer; - GSCM_top_level toplvl; - char * str; -{ - SCM_STACKITEM i; - GSCM_status status; - scm_stack_base = &i; - status = eval_str (answer, toplvl, str); - scm_stack_base = 0; - return status; -} - - - -GSCM_status -gscm_eval_file (answer, toplvl, file_name) - char ** answer; - GSCM_top_level toplvl; - char * file_name; -{ - char command[MAXPATHLEN * 3]; - format_load_command (command, file_name); - return gscm_eval_str (answer, toplvl, command); -} - - - - -/* {Error Messages} - */ - - -#ifdef __GNUC__ -# define AT(X) [X] = -#else -# define AT(X) -#endif - -static char * gscm_error_msgs[] = -{ - AT(GSCM_OK) "No error.", - AT(GSCM_ERROR) "ERROR in init file.", - AT(GSCM_ILLEGALLY_REENTERED) "Gscm function was illegally reentered.", - AT(GSCM_OUT_OF_MEM) "Out of memory.", - AT(GSCM_ERROR_OPENING_FILE) "Error opening file.", - AT(GSCM_ERROR_OPENING_INIT_FILE) "Error opening init file." -}; - - -char * -gscm_error_msg (n) - int n; -{ - if ((n < 0) || (n > (sizeof (gscm_error_msgs) / sizeof (char *)))) - return "Unrecognized error."; - else - return gscm_error_msgs[n]; -} - - - -/* {Defining New Procedures} - */ - - -SCM -gscm_make_subr (fn, req, opt, varp, doc) - SCM (*fn)(); - int req; - int opt; - int varp; - char * doc; -{ - return scm_make_gsubr ("*anonymous*", req, opt, varp, fn); -} - - -int -gscm_2_char (c) - SCM c; -{ - SCM_ASSERT (SCM_ICHRP (c), c, SCM_ARG1, "gscm_2_char"); - return SCM_ICHR (c); -} - - - - -void -gscm_2_str (out, len_out, objp) - char ** out; - int * len_out; - SCM * objp; -{ - SCM_ASSERT (SCM_NIMP (*objp) && SCM_STRINGP (*objp), *objp, SCM_ARG3, "gscm_2_str"); - if (out) - *out = SCM_CHARS (*objp); - if (len_out) - *len_out = SCM_LENGTH (*objp); -} - - - -void -gscm_error (message, args) - char * message; - SCM args; -{ - SCM errsym; - SCM str; - - errsym = SCM_CAR (scm_intern ("error", 5)); - str = scm_makfrom0str (message); - scm_throw (errsym, scm_cons (str, args)); -} - - - -GSCM_status -gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd) - int argc; - char ** argv; - FILE * in; - FILE * out; - FILE * err; - GSCM_status (*initfn)(); - char * initfile; - char * initcmd; -{ - SCM_STACKITEM i; - GSCM_status status; - GSCM_top_level top; - - scm_ports_prehistory (); - scm_smob_prehistory (); - scm_tables_prehistory (); - scm_init_storage (0); - scm_start_stack (&i, in, out, err); - scm_init_gsubr (); - scm_init_curry (); - scm_init_feature (); -/* scm_init_debug (); */ - scm_init_alist (); - scm_init_append (); - scm_init_arbiters (); - scm_init_async (); - scm_init_boolean (); - scm_init_chars (); - scm_init_continuations (); - scm_init_dynwind (); - scm_init_eq (); - scm_init_error (); - scm_init_fports (); - scm_init_files (); - scm_init_gc (); - scm_init_hash (); - scm_init_hashtab (); - scm_init_kw (); - scm_init_list (); - scm_init_lvectors (); - scm_init_numbers (); - scm_init_pairs (); - scm_init_ports (); - scm_init_procs (); - scm_init_procprop (); - scm_init_scmsigs (); - scm_init_stackchk (); - scm_init_strports (); - scm_init_struct (); - scm_init_symbols (); - scm_init_load (); - scm_init_print (); - scm_init_read (); - scm_init_sequences (); - scm_init_stime (); - scm_init_strings (); - scm_init_strorder (); - scm_init_mbstrings (); - scm_init_strop (); - scm_init_throw (); - scm_init_variable (); - scm_init_vectors (); - scm_init_version (); - scm_init_weaks (); - scm_init_vports (); - scm_init_eval (); - scm_init_ramap (); - scm_init_unif (); - scm_init_simpos (); - scm_init_elisp (); - scm_init_mallocs (); - scm_init_cnsvobj (); - scm_init_guile (); - initfn (); - - /* Save the argument list to be the return value of (program-arguments). - */ - scm_progargs = scm_makfromstrs (argc, argv); - - scm_gc_heap_lock = 0; - errno = 0; - scm_ints_disabled = 1; - -/* init_basic (); */ - -/* init_init(); */ - - if (initfile == NULL) - { - initfile = getenv ("GUILE_INIT_PATH"); - if (initfile == NULL) - initfile = SCM_IMPLINIT; - } - - if (initfile == NULL) - { - status = GSCM_OK; - } - else - { - SCM answer; - - status = gscm_seval_file (&answer, -1, initfile); - if ((status == GSCM_OK) && (answer == SCM_BOOL_F)) - status = GSCM_ERROR_OPENING_INIT_FILE; - } - - top = SCM_EOL; - - if (status == GSCM_OK) - { - scm_sysintern ("*stdin*", scm_cur_inp); - status = gscm_seval_str (0, top, initcmd); - } - return status; -} - - - - -void -scm_init_guile () -{ -#include "gscm.x" -} - diff --git a/libguile/gscm.h b/libguile/gscm.h deleted file mode 100644 index 7e0554e5e..000000000 --- a/libguile/gscm.h +++ /dev/null @@ -1,281 +0,0 @@ -/* classes: h_files */ - -#ifndef GSCMH -#define GSCMH - -/* Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile.h" - - -/* {Locking Out Async Execution (including async GC) and Non-Local Exits} - */ - -#define GSCM_DEFER_INTS SCM_DEFER_INTS -#define GSCM_ALLOW_INTS SCM_ALLOW_INTS - - -/* {Common Constants} - */ - -#define GSCM_EOL SCM_EOL -#define GSCM_FALSE SCM_BOOL_F -#define GSCM_TRUE SCM_BOOL_T - -#define GSCM_EOL_MARKER SCM_UNDEFINED -#define GSCM_NOT_PASSED SCM_UNDEFINED -#define GSCM_UNSPECIFIED SCM_UNSPECIFIED - - -/* {Booleans} - */ - -#define gscm_bool(CBOOL) ((CBOOL) ? SCM_BOOL_T : SCM_BOOL_F) -#define gscm_2_bool(BOOL) (((BOOL) == SCM_BOOL_F) ? 0 : 1) - - -/* {Numbers} - */ - -#define gscm_ulong scm_ulong2num -#define gscm_long scm_long2num -#define gscm_double(X) scm_makdbl ((X), 0.0) - -#define gscm_2_ulong(OBJ) scm_num2ulong((OBJ), (char *)SCM_ARG1, "gscm_2_ulong") -#define gscm_2_long(OBJ) scm_num2long((OBJ), (char *)SCM_ARG1, "gscm_2_long") -#define gscm_2_double(OBJ) scm_num2dbl((OBJ), "gscm_2_double") - - -/* {Characters} - */ - -#define gscm_char(C) SCM_MAKICHR(C) -/* extern int gscm_2_char P((SCM)); */ - - -/* {Strings} - */ - -#define gscm_str(SRC, LEN) scm_makfromstr (SRC, LEN, 0) -#define gscm_str0 scm_makfrom0str - - - -/* {Pairs and Lists} - */ - -#define gscm_cons scm_cons -#define gscm_list scm_listify -#define gscm_ilength scm_ilength - - -#define gscm_set_car(OBJ, VAL) \ - ((SCM_NIMP(OBJ) && SCM_CONSP(OBJ)) \ - ? (SCM_CAR(OBJ) = VAL) \ - : scm_wta ((OBJ), (char *)SCM_ARG1, "set-car!")) - -#define gscm_set_cdr(OBJ, VAL) \ - ((SCM_NIMP(OBJ) && SCM_CONSP(OBJ)) \ - ? (SCM_CDR(OBJ) = VAL) \ - : scm_wta ((OBJ), (char *)SCM_ARG1, "set-cdr!")) - - -#define GSCM_SAFE_CAR(X) ((SCM_NIMP(X) && SCM_CONSP(X)) \ - ? SCM_CAR(X) \ - : scm_wta ((X), (char *)SCM_ARG1, "car")) - -#define GSCM_SAFE_CDR(X) ((SCM_NIMP(X) && SCM_CONSP(X)) \ - ? SCM_CDR(X) \ - : scm_wta ((X), (char *)SCM_ARG1, "cdr")) - -#define gscm_car(OBJ) GSCM_SAFE_CAR (OBJ) -#define gscm_cdr(OBJ) GSCM_SAFE_CDR (OBJ) - -#define gscm_caar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)) -#define gscm_cdar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)) -#define gscm_cadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)) -#define gscm_cddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)) - -#define gscm_caaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))) -#define gscm_cdaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))) -#define gscm_cadar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))) -#define gscm_cddar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))) -#define gscm_caadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))) -#define gscm_cdadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))) -#define gscm_caddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))) -#define gscm_cdddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))) - -#define gscm_caaaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_cdaaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_cadaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_cddaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_caadar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_cdadar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_caddar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_cdddar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))) -#define gscm_caaadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cdaadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cadadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cddadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_caaddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cdaddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cadddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))) -#define gscm_cddddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))) - - -/* {Symbols} - */ - -#define gscm_symbol(STR, LEN) SCM_CAR(scm_intern (STR, LEN)) -#define gscm_tmp_symbol(STR, LEN) SCM_CAR(scm_intern_obarray (STR, LEN, SCM_BOOL_F)) - - -/* {Vectors} - */ - -#define gscm_vector(N, FILL) scm_make_vector (SCM_MAKINUM(N), (FILL), SCM_UNDEFINED) -#define gscm_vref(V, I) scm_vector_ref ((V), SCM_MAKINUM(I)) -#define gscm_vset(V, I, VAL) scm_vector_set_x ((V), SCM_MAKINUM(I), (VAL)) - - -/* {Procedures} - */ - -/* extern SCM gscm_make_subr P((SCM (*fn)(), int req, int opt, int varp, char * doc)); */ -/* extern SCM gscm_curry P((SCM procedure, SCM first_arg)); */ - -#define gscm_apply(PROC, ARGS) scm_apply ((PROC), (ARGS), SCM_EOL) - - - -/* {Non-local Exits} - */ - - -#define gscm_catch(T, TH, H) scm_catch ((T), (TH), (H)) -#define gscm_throw(T, V) scm_throw ((T), (V)) -#define gscm_dynamic_wind(E, T, L) scm_dynwind ((E), (T), (L)) -/* extern void gscm_error P((char * message, SCM args)); */ - - -/* {I/O} - */ - -#define gscm_print_obj scm_prin1 -#define gscm_putc scm_putc -#define gscm_puts scm_puts -#define gscm_fwrite scm_fwrite -#define gscm_flush scm_flush - -extern char * gscm_last_attempted_init_file; - -/* {Equivalence} - */ - - -#define gscm_is_eq(OBJ) (SCM_BOOL_F != scm_eq (OBJ)) -#define gscm_is_eqv(OBJ) (SCM_BOOL_F != scm_eqv (OBJ)) -#define gscm_is_equal(OBJ) (SCM_BOOL_F != scm_equal_p (OBJ)) - - -/* {Procedure Properties} - */ - -#define gscm_procedure_properties scm_procedure_properties -#define gscm_set_procedure_properties_x scm_set_procedure_properties_x -#define gscm_procedure_property scm_procedure_property -#define gscm_set_procedure_property_x scm_set_procedure_property_x - - -/* {Generic Length Procedure} - */ - -#define gscm_obj_length scm_obj_length - - -/* {Proc Declaration Macro} - */ -#ifndef GSCM_MAGIC_SNARFER -#define GSCM_PROC(RANAME, CFN, STR, REQ, OPT, VAR) \ - static char RANAME[]=STR; -#else -#define GSCM_PROC(RANAME, CFN, STR, REQ, OPT, VAR) \ -%%% gscm_define_procedure (RANAME, CFN, REQ, OPT, VAR, "") -#endif - -#define gscm_define_procedure(NAME, FN, REQ, OPT, VARP, DOC) scm_make_gsubr(name, req, opt, varp, fn) -#define gscm_curry scm_curry -#define gscm_define scm_sysintern - - -typedef int GSCM_top_level; - - -/* {Error Returns} - */ - -typedef int GSCM_status; - -#define GSCM_OK 0 -#define GSCM_ERROR 1 -#define GSCM_ILLEGALLY_REENTERED 2 -#define GSCM_OUT_OF_MEM 3 -#define GSCM_ERROR_OPENING_FILE 4 -#define GSCM_ERROR_OPENING_INIT_FILE 5 - - - -extern GSCM_status gscm_seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str)); -extern GSCM_status gscm_seval_file SCM_P ((SCM *answer, GSCM_top_level toplvl, char * file_name)); -extern GSCM_status gscm_eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str)); -extern GSCM_status gscm_eval_file SCM_P ((char ** answer, GSCM_top_level toplvl, char * file_name)); -extern GSCM_status gscm_run_scm SCM_P ((int argc, char ** argv, FILE * in, FILE * out, FILE * err, GSCM_status (*initfn)(void), char * initfile, char * initcmd)); -extern char * gscm_error_msg SCM_P ((int n)); -extern SCM gscm_make_subr SCM_P ((SCM (*fn)(), int req, int opt, int varp, char * doc)); -extern int gscm_2_char SCM_P ((SCM c)); -extern void gscm_2_str SCM_P ((char ** out, int * len_out, SCM * objp)); -extern void gscm_error SCM_P ((char * message, SCM args)); -extern void scm_init_guile SCM_P ((void)); - -#endif /* GSCMH */ - diff --git a/libguile/gsubr.c b/libguile/gsubr.c deleted file mode 100644 index b69a6c497..000000000 --- a/libguile/gsubr.c +++ /dev/null @@ -1,193 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "procprop.h" - -#include "gsubr.h" - -/* - * gsubr.c - * Provide `gsubrs' -- subrs taking a prescribed number of required, optional, - * and rest arguments. - */ - -#include "gsubr.h" - -#define GSUBR_TEST 1 - -#define GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8)) -#define GSUBR_REQ(x) ((int)(x)&0xf) -#define GSUBR_OPT(x) (((int)(x)&0xf0)>>4) -#define GSUBR_REST(x) ((int)(x)>>8) - -#define GSUBR_MAX 10 -#define GSUBR_TYPE(cclo) (SCM_VELTS(cclo)[1]) -#define GSUBR_PROC(cclo) (SCM_VELTS(cclo)[2]) - -SCM scm_i_name; -static SCM f_gsubr_apply; - -SCM -scm_make_gsubr(name, req, opt, rst, fcn) - char *name; - int req; - int opt; - int rst; - SCM (*fcn)(); -{ - switch GSUBR_MAKTYPE(req, opt, rst) { - case GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, scm_tc7_subr_0, fcn); - case GSUBR_MAKTYPE(1, 0, 0): return scm_make_subr(name, scm_tc7_subr_1, fcn); - case GSUBR_MAKTYPE(0, 1, 0): return scm_make_subr(name, scm_tc7_subr_1o, fcn); - case GSUBR_MAKTYPE(1, 1, 0): return scm_make_subr(name, scm_tc7_subr_2o, fcn); - case GSUBR_MAKTYPE(2, 0, 0): return scm_make_subr(name, scm_tc7_subr_2, fcn); - case GSUBR_MAKTYPE(3, 0, 0): return scm_make_subr(name, scm_tc7_subr_3, fcn); - case GSUBR_MAKTYPE(0, 0, 1): return scm_make_subr(name, scm_tc7_lsubr, fcn); - case GSUBR_MAKTYPE(2, 0, 1): return scm_make_subr(name, scm_tc7_lsubr_2, fcn); - default: - { - SCM symcell = scm_sysintern(name, SCM_UNDEFINED); - SCM z, cclo = scm_makcclo(f_gsubr_apply, 3L); - long tmp = ((((SCM_CELLPTR)(SCM_CAR(symcell)))-scm_heap_org)<<8); - if (GSUBR_MAX < req + opt + rst) { - fputs("ERROR in scm_make_gsubr: too many args\n", stderr); - exit (1); - } - if ((tmp>>8) != ((SCM_CELLPTR)(SCM_CAR(symcell))-scm_heap_org)) - tmp = 0; - SCM_NEWCELL(z); - SCM_SUBRF(z) = fcn; - SCM_SETCAR (z, tmp + scm_tc7_subr_0); - GSUBR_PROC(cclo) = z; - GSUBR_TYPE(cclo) = SCM_MAKINUM(GSUBR_MAKTYPE(req, opt, rst)); - SCM_SETCDR (symcell, cclo); -#ifdef DEBUG_EXTENSIONS - if (SCM_REC_PROCNAMES_P) - scm_set_procedure_property_x (cclo, scm_i_name, SCM_CAR (symcell)); -#endif - return cclo; - } - } -} - - -SCM_PROC(s_gsubr_apply, "gsubr-apply", 0, 0, 1, scm_gsubr_apply); - -SCM -scm_gsubr_apply(args) - SCM args; -{ - SCM self = SCM_CAR(args); - SCM (*fcn)() = SCM_SUBRF(GSUBR_PROC(self)); - SCM v[10]; /* must agree with greatest supported arity */ - int typ = SCM_INUM(GSUBR_TYPE(self)); - int i, n = GSUBR_REQ(typ) + GSUBR_OPT(typ) + GSUBR_REST(typ); - args = SCM_CDR(args); - for (i = 0; i < GSUBR_REQ(typ); i++) { -#ifndef RECKLESS - if (SCM_IMP(args)) - scm_wrong_num_args (SCM_SNAME(GSUBR_PROC(self))); -#endif - v[i] = SCM_CAR(args); - args = SCM_CDR(args); - } - for (; i < GSUBR_REQ(typ) + GSUBR_OPT(typ); i++) { - if (SCM_NIMP(args)) { - v[i] = SCM_CAR(args); - args = SCM_CDR(args); - } - else - v[i] = SCM_UNDEFINED; - } - if (GSUBR_REST(typ)) - v[i] = args; - switch (n) { - default: scm_wta(self, "internal programming error", s_gsubr_apply); - case 2: return (*fcn)(v[0], v[1]); - case 3: return (*fcn)(v[0], v[1], v[2]); - case 4: return (*fcn)(v[0], v[1], v[2], v[3]); - case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]); - case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]); - case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]); - case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]); - case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]); - case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]); - } -} - - -#ifdef GSUBR_TEST -/* A silly example, taking 2 required args, 1 optional, and - a scm_list of rest args - */ -SCM -gsubr_21l(req1, req2, opt, rst) - SCM req1, req2, opt, rst; -{ - scm_gen_puts (scm_regular_string, "gsubr-2-1-l:\n req1: ", scm_cur_outp); - scm_display(req1, scm_cur_outp); - scm_gen_puts (scm_regular_string, "\n req2: ", scm_cur_outp); - scm_display(req2, scm_cur_outp); - scm_gen_puts (scm_regular_string, "\n opt: ", scm_cur_outp); - scm_display(opt, scm_cur_outp); - scm_gen_puts (scm_regular_string, "\n rest: ", scm_cur_outp); - scm_display(rst, scm_cur_outp); - scm_newline(scm_cur_outp); - return SCM_UNSPECIFIED; -} -#endif - - - -void -scm_init_gsubr() -{ - f_gsubr_apply = scm_make_subr(s_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply); - scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED)); - scm_permanent_object (scm_i_name); -#ifdef GSUBR_TEST - scm_make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */ -#endif -} diff --git a/libguile/gsubr.h b/libguile/gsubr.h deleted file mode 100644 index 7eb34ce02..000000000 --- a/libguile/gsubr.h +++ /dev/null @@ -1,55 +0,0 @@ -/* classes: h_files */ - -#ifndef GSUBRH -#define GSUBRH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_make_gsubr SCM_P ((char *name, int req, int opt, int rst, SCM (*fcn)())); -extern SCM scm_gsubr_apply SCM_P ((SCM args)); -extern void scm_init_gsubr SCM_P ((void)); - -#endif /* GSUBRH */ diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in deleted file mode 100644 index e9254cdbc..000000000 --- a/libguile/guile-snarf.in +++ /dev/null @@ -1,4 +0,0 @@ -#!/bin/sh -# Extract the initialization actions for builtin things. - -@CPP@ -DSCM_MAGIC_SNARFER $* | grep "^%%%" | sed -e "s/^%%%//" diff --git a/libguile/hash.c b/libguile/hash.c deleted file mode 100644 index 3ea9f866a..000000000 --- a/libguile/hash.c +++ /dev/null @@ -1,222 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "hash.h" - - -#ifndef floor -extern double floor(); -#endif - - -unsigned long -scm_hasher(obj, n, d) - SCM obj; - unsigned long n; - scm_sizet d; -{ - switch (7 & (int) obj) { - case 2: case 6: /* SCM_INUMP(obj) */ - return SCM_INUM(obj) % n; - case 4: - if SCM_ICHRP(obj) - return (unsigned)(scm_downcase(SCM_ICHR(obj))) % n; - switch ((int) obj) { -#ifndef SICP - case (int) SCM_EOL: d = 256; break; -#endif - case (int) SCM_BOOL_T: d = 257; break; - case (int) SCM_BOOL_F: d = 258; break; - case (int) SCM_EOF_VAL: d = 259; break; - default: d = 263; /* perhaps should be error */ - } - return d % n; - default: return 263 % n; /* perhaps should be error */ - case 0: - switch SCM_TYP7(obj) { - default: return 263 % n; - case scm_tc7_smob: - switch SCM_TYP16(obj) { - case scm_tcs_bignums: - bighash: return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n))); - default: return 263 % n; -#ifdef SCM_FLOATS - case scm_tc16_flo: - if SCM_REALP(obj) { - double r = SCM_REALPART(obj); - if (floor(r)==r) { - obj = scm_inexact_to_exact (obj); - if SCM_IMP(obj) return SCM_INUM(obj) % n; - goto bighash; - } - } - obj = scm_number_to_string(obj, SCM_MAKINUM(10)); -#endif - } - case scm_tcs_symbols: - case scm_tc7_string: - case scm_tc7_mb_string: - case scm_tc7_substring: - case scm_tc7_mb_substring: - return scm_strhash(SCM_ROUCHARS(obj), (scm_sizet) SCM_ROLENGTH(obj), n); - case scm_tc7_wvect: - case scm_tc7_vector: - { - scm_sizet len = SCM_LENGTH(obj); - SCM *data = SCM_VELTS(obj); - if (len>5) - { - scm_sizet i = d/2; - unsigned long h = 1; - while (i--) h = ((h<<8) + (scm_hasher(data[h % len], n, 2))) % n; - return h; - } - else - { - scm_sizet i = len; - unsigned long h = (n)-1; - while (i--) h = ((h<<8) + (scm_hasher(data[i], n, d/len))) % n; - return h; - } - } - case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: - if (d) return (scm_hasher(SCM_CAR(obj), n, d/2)+scm_hasher(SCM_CDR(obj), n, d/2)) % n; - else return 1; - case scm_tc7_port: - return ((SCM_RDNG & SCM_CAR(obj)) ? 260 : 261) % n; - case scm_tcs_closures: case scm_tc7_contin: case scm_tcs_subrs: - return 262 % n; - } - } -} - - - - - -unsigned int -scm_ihashq (obj, n) - SCM obj; - unsigned int n; -{ - return (((unsigned int) obj) >> 1) % n; -} - - -SCM_PROC(s_hashq, "hashq", 2, 0, 0, scm_hashq); - -SCM -scm_hashq(obj, n) - SCM obj; - SCM n; -{ - SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashq); - return SCM_MAKINUM(scm_ihashq (obj, SCM_INUM (n))); -} - - - - - -unsigned int -scm_ihashv (obj, n) - SCM obj; - unsigned int n; -{ - if (SCM_ICHRP(obj)) - return ((unsigned int)(scm_downcase(SCM_ICHR(obj)))) % n; /* downcase!?!! */ - - if (SCM_NIMP(obj) && SCM_NUMP(obj)) - return (unsigned int) scm_hasher(obj, n, 10); - else - return ((unsigned int)obj) % n; -} - - -SCM_PROC(s_hashv, "hashv", 2, 0, 0, scm_hashv); - -SCM -scm_hashv(obj, n) - SCM obj; - SCM n; -{ - SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashv); - return SCM_MAKINUM(scm_ihashv (obj, SCM_INUM (n))); -} - - - - - -unsigned int -scm_ihash (obj, n) - SCM obj; - unsigned int n; -{ - return (unsigned int)scm_hasher (obj, n, 10); -} - -SCM_PROC(s_hash, "hash", 2, 0, 0, scm_hash); - -SCM -scm_hash(obj, n) - SCM obj; - SCM n; -{ - SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hash); - return SCM_MAKINUM(scm_ihash(obj, SCM_INUM(n))); -} - - - - - -void -scm_init_hash () -{ -#include "hash.x" -} - diff --git a/libguile/hash.h b/libguile/hash.h deleted file mode 100644 index b9637d0c0..000000000 --- a/libguile/hash.h +++ /dev/null @@ -1,60 +0,0 @@ -/* classes: h_files */ - -#ifndef HASHH -#define HASHH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern unsigned long scm_hasher SCM_P ((SCM obj, unsigned long n, scm_sizet d)); -extern unsigned int scm_ihashq SCM_P ((SCM obj, unsigned int n)); -extern SCM scm_hashq SCM_P ((SCM obj, SCM n)); -extern unsigned int scm_ihashv SCM_P ((SCM obj, unsigned int n)); -extern SCM scm_hashv SCM_P ((SCM obj, SCM n)); -extern unsigned int scm_ihash SCM_P ((SCM obj, unsigned int n)); -extern SCM scm_hash SCM_P ((SCM obj, SCM n)); -extern void scm_init_hash SCM_P ((void)); - -#endif /* HASHH */ diff --git a/libguile/hashtab.c b/libguile/hashtab.c deleted file mode 100644 index a3cd76499..000000000 --- a/libguile/hashtab.c +++ /dev/null @@ -1,540 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "alist.h" -#include "hash.h" -#include "eval.h" - -#include "hashtab.h" - - - -SCM -scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; -{ - int k; - SCM h; - - SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_get_handle"); - if (SCM_LENGTH (table) == 0) - return SCM_EOL; - k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - SCM_MAKINUM (k), - SCM_OUTOFRANGE, - "hash_fn_get_handle"); - h = assoc_fn (obj, SCM_VELTS (table)[k], closure); - return h; -} - - - -SCM -scm_hash_fn_create_handle_x (table, obj, init, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - SCM init; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; -{ - int k; - SCM it; - - SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_create_handle_x"); - if (SCM_LENGTH (table) == 0) - return SCM_EOL; - k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - SCM_MAKINUM (k), - SCM_OUTOFRANGE, - "hash_fn_create_handle_x"); - SCM_REDEFER_INTS; - it = assoc_fn (obj, SCM_VELTS (table)[k], closure); - if (SCM_NIMP (it)) - { - return it; - } - { - SCM new_bucket; - SCM old_bucket; - old_bucket = SCM_VELTS (table)[k]; - new_bucket = scm_acons (obj, init, old_bucket); - SCM_VELTS(table)[k] = new_bucket; - SCM_REALLOW_INTS; - return SCM_CAR (new_bucket); - } -} - - - - -SCM -scm_hash_fn_ref (table, obj, dflt, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - SCM dflt; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; -{ - SCM it; - - it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure); - if (SCM_IMP (it)) - return dflt; - else - return SCM_CDR (it); -} - - - - -SCM -scm_hash_fn_set_x (table, obj, val, hash_fn, assoc_fn, closure) - SCM table; - SCM obj; - SCM val; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - void * closure; -{ - SCM it; - - it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure); - SCM_SETCDR (it, val); - return val; -} - - - - - -SCM -scm_hash_fn_remove_x (table, obj, hash_fn, assoc_fn, delete_fn, closure) - SCM table; - SCM obj; - unsigned int (*hash_fn)(); - SCM (*assoc_fn)(); - SCM (*delete_fn)(); - void * closure; -{ - int k; - SCM h; - - SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x"); - if (SCM_LENGTH (table) == 0) - return SCM_EOL; - k = hash_fn (obj, SCM_LENGTH (table), closure); - SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)), - SCM_MAKINUM (k), - SCM_OUTOFRANGE, - "hash_fn_remove_x"); - h = assoc_fn (obj, SCM_VELTS (table)[k], closure); - SCM_VELTS(table)[k] = delete_fn (h, SCM_VELTS(table)[k]); - return h; -} - - - - -SCM_PROC (s_hashq_get_handle, "hashq-get-handle", 2, 0, 0, scm_hashq_get_handle); - -SCM -scm_hashq_get_handle (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_get_handle (table, obj, scm_ihashq, scm_sloppy_assq, 0); -} - - -SCM_PROC (s_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, scm_hashq_create_handle_x); - -SCM -scm_hashq_create_handle_x (table, obj, init) - SCM table; - SCM obj; - SCM init; -{ - return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashq, scm_sloppy_assq, 0); -} - - -SCM_PROC (s_hashq_ref, "hashq-ref", 2, 1, 0, scm_hashq_ref); - -SCM -scm_hashq_ref (table, obj, dflt) - SCM table; - SCM obj; - SCM dflt; -{ - if (dflt == SCM_UNDEFINED) - dflt = SCM_BOOL_F; - return scm_hash_fn_ref (table, obj, dflt, scm_ihashq, scm_sloppy_assq, 0); -} - - - -SCM_PROC (s_hashq_set_x, "hashq-set!", 3, 0, 0, scm_hashq_set_x); - -SCM -scm_hashq_set_x (table, obj, val) - SCM table; - SCM obj; - SCM val; -{ - return scm_hash_fn_set_x (table, obj, val, scm_ihashq, scm_sloppy_assq, 0); -} - - - -SCM_PROC (s_hashq_remove_x, "hashq-remove!", 2, 0, 0, scm_hashq_remove_x); - -SCM -scm_hashq_remove_x (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_remove_x (table, obj, scm_ihashq, scm_sloppy_assq, scm_delq_x, 0); -} - - - - -SCM_PROC (s_hashv_get_handle, "hashv-get-handle", 2, 0, 0, scm_hashv_get_handle); - -SCM -scm_hashv_get_handle (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_get_handle (table, obj, scm_ihashv, scm_sloppy_assv, 0); -} - - -SCM_PROC (s_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, scm_hashv_create_handle_x); - -SCM -scm_hashv_create_handle_x (table, obj, init) - SCM table; - SCM obj; - SCM init; -{ - return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashv, scm_sloppy_assv, 0); -} - - -SCM_PROC (s_hashv_ref, "hashv-ref", 2, 1, 0, scm_hashv_ref); - -SCM -scm_hashv_ref (table, obj, dflt) - SCM table; - SCM obj; - SCM dflt; -{ - if (dflt == SCM_UNDEFINED) - dflt = SCM_BOOL_F; - return scm_hash_fn_ref (table, obj, dflt, scm_ihashv, scm_sloppy_assv, 0); -} - - - -SCM_PROC (s_hashv_set_x, "hashv-set!", 3, 0, 0, scm_hashv_set_x); - -SCM -scm_hashv_set_x (table, obj, val) - SCM table; - SCM obj; - SCM val; -{ - return scm_hash_fn_set_x (table, obj, val, scm_ihashv, scm_sloppy_assv, 0); -} - - -SCM_PROC (s_hashv_remove_x, "hashv-remove!", 2, 0, 0, scm_hashv_remove_x); - -SCM -scm_hashv_remove_x (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_remove_x (table, obj, scm_ihashv, scm_sloppy_assv, scm_delv_x, 0); -} - - - -SCM_PROC (s_hash_get_handle, "hash-get-handle", 2, 0, 0, scm_hash_get_handle); - -SCM -scm_hash_get_handle (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_get_handle (table, obj, scm_ihash, scm_sloppy_assoc, 0); -} - - -SCM_PROC (s_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, scm_hash_create_handle_x); - -SCM -scm_hash_create_handle_x (table, obj, init) - SCM table; - SCM obj; - SCM init; -{ - return scm_hash_fn_create_handle_x (table, obj, init, scm_ihash, scm_sloppy_assoc, 0); -} - - -SCM_PROC (s_hash_ref, "hash-ref", 2, 1, 0, scm_hash_ref); - -SCM -scm_hash_ref (table, obj, dflt) - SCM table; - SCM obj; - SCM dflt; -{ - if (dflt == SCM_UNDEFINED) - dflt = SCM_BOOL_F; - return scm_hash_fn_ref (table, obj, dflt, scm_ihash, scm_sloppy_assoc, 0); -} - - - -SCM_PROC (s_hash_set_x, "hash-set!", 3, 0, 0, scm_hash_set_x); - -SCM -scm_hash_set_x (table, obj, val) - SCM table; - SCM obj; - SCM val; -{ - return scm_hash_fn_set_x (table, obj, val, scm_ihash, scm_sloppy_assoc, 0); -} - - - -SCM_PROC (s_hash_remove_x, "hash-remove!", 2, 0, 0, scm_hash_remove_x); - -SCM -scm_hash_remove_x (table, obj) - SCM table; - SCM obj; -{ - return scm_hash_fn_remove_x (table, obj, scm_ihash, scm_sloppy_assoc, scm_delete_x, 0); -} - - - - -struct scm_ihashx_closure -{ - SCM hash; - SCM assoc; - SCM delete; -}; - - - -static unsigned int scm_ihashx SCM_P ((SCM obj, unsigned int n, struct scm_ihashx_closure * closure)); - -static unsigned int -scm_ihashx (obj, n, closure) - SCM obj; - unsigned int n; - struct scm_ihashx_closure * closure; -{ - SCM answer; - SCM_ALLOW_INTS; - answer = scm_apply (closure->hash, - scm_listify (obj, scm_ulong2num ((unsigned long)n), SCM_UNDEFINED), - SCM_EOL); - SCM_DEFER_INTS; - return SCM_INUM (answer); -} - - - -static SCM scm_sloppy_assx SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure)); - -static SCM -scm_sloppy_assx (obj, alist, closure) - SCM obj; - SCM alist; - struct scm_ihashx_closure * closure; -{ - SCM answer; - SCM_ALLOW_INTS; - answer = scm_apply (closure->assoc, - scm_listify (obj, alist, SCM_UNDEFINED), - SCM_EOL); - SCM_DEFER_INTS; - return answer; -} - - - - -static SCM scm_delx_x SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure)); - -static SCM -scm_delx_x (obj, alist, closure) - SCM obj; - SCM alist; - struct scm_ihashx_closure * closure; -{ - SCM answer; - SCM_ALLOW_INTS; - answer = scm_apply (closure->delete, - scm_listify (obj, alist, SCM_UNDEFINED), - SCM_EOL); - SCM_DEFER_INTS; - return answer; -} - - - -SCM_PROC (s_hashx_get_handle, "hashx-get-handle", 4, 0, 0, scm_hashx_get_handle); - -SCM -scm_hashx_get_handle (hash, assoc, table, obj) - SCM hash; - SCM assoc; - SCM table; - SCM obj; -{ - struct scm_ihashx_closure closure; - closure.hash = hash; - closure.assoc = assoc; - return scm_hash_fn_get_handle (table, obj, scm_ihashx, scm_sloppy_assx, (void *)&closure); -} - - -SCM_PROC (s_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, scm_hashx_create_handle_x); - -SCM -scm_hashx_create_handle_x (hash, assoc, table, obj, init) - SCM hash; - SCM assoc; - SCM table; - SCM obj; - SCM init; -{ - struct scm_ihashx_closure closure; - closure.hash = hash; - closure.assoc = assoc; - return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashx, scm_sloppy_assx, (void *)&closure); -} - - - -SCM_PROC (s_hashx_ref, "hashx-ref", 4, 1, 0, scm_hashx_ref); - -SCM -scm_hashx_ref (hash, assoc, table, obj, dflt) - SCM hash; - SCM assoc; - SCM table; - SCM obj; - SCM dflt; -{ - struct scm_ihashx_closure closure; - if (dflt == SCM_UNDEFINED) - dflt = SCM_BOOL_F; - closure.hash = hash; - closure.assoc = assoc; - return scm_hash_fn_ref (table, obj, dflt, scm_ihashx, scm_sloppy_assx, (void *)&closure); -} - - - - -SCM_PROC (s_hashx_set_x, "hashx-set!", 5, 0, 0, scm_hashx_set_x); - -SCM -scm_hashx_set_x (hash, assoc, table, obj, val) - SCM hash; - SCM assoc; - SCM table; - SCM obj; - SCM val; -{ - struct scm_ihashx_closure closure; - closure.hash = hash; - closure.assoc = assoc; - return scm_hash_fn_set_x (table, obj, val, scm_ihashx, scm_sloppy_assx, (void *)&closure); -} - - - -SCM -scm_hashx_remove_x (hash, assoc, delete, table, obj) - SCM hash; - SCM assoc; - SCM delete; - SCM table; - SCM obj; -{ - struct scm_ihashx_closure closure; - closure.hash = hash; - closure.assoc = assoc; - closure.delete = delete; - return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx, scm_delx_x, 0); -} - - - - -void -scm_init_hashtab () -{ -#include "hashtab.x" -} - diff --git a/libguile/hashtab.h b/libguile/hashtab.h deleted file mode 100644 index f53d25663..000000000 --- a/libguile/hashtab.h +++ /dev/null @@ -1,84 +0,0 @@ -/* classes: h_files */ - -#ifndef HASHTABH -#define HASHTABH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -#if 0 -typedef unsigned int scm_hash_fn_t SCM_P ((SCM obj, unsigned int d, void *closure)); -typedef SCM scm_assoc_fn_t SCM_P ((SCM key, SCM alist, void *closure)); -typedef SCM scm_delete_fn_t SCM_P ((SCM elt, SCM list)); -#endif - -extern SCM scm_hash_fn_get_handle SCM_P ((SCM table, SCM obj, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure)); -extern SCM scm_hash_fn_create_handle_x SCM_P ((SCM table, SCM obj, SCM init, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure)); -extern SCM scm_hash_fn_ref SCM_P ((SCM table, SCM obj, SCM dflt, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure)); -extern SCM scm_hash_fn_set_x SCM_P ((SCM table, SCM obj, SCM val, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure)); -extern SCM scm_hash_fn_remove_x SCM_P ((SCM table, SCM obj, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), SCM (*delete_fn) (), void * closure)); - -extern SCM scm_hashq_get_handle SCM_P ((SCM table, SCM obj)); -extern SCM scm_hashq_create_handle_x SCM_P ((SCM table, SCM obj, SCM init)); -extern SCM scm_hashq_ref SCM_P ((SCM table, SCM obj, SCM dflt)); -extern SCM scm_hashq_set_x SCM_P ((SCM table, SCM obj, SCM val)); -extern SCM scm_hashq_remove_x SCM_P ((SCM table, SCM obj)); -extern SCM scm_hashv_get_handle SCM_P ((SCM table, SCM obj)); -extern SCM scm_hashv_create_handle_x SCM_P ((SCM table, SCM obj, SCM init)); -extern SCM scm_hashv_ref SCM_P ((SCM table, SCM obj, SCM dflt)); -extern SCM scm_hashv_set_x SCM_P ((SCM table, SCM obj, SCM val)); -extern SCM scm_hashv_remove_x SCM_P ((SCM table, SCM obj)); -extern SCM scm_hash_get_handle SCM_P ((SCM table, SCM obj)); -extern SCM scm_hash_create_handle_x SCM_P ((SCM table, SCM obj, SCM init)); -extern SCM scm_hash_ref SCM_P ((SCM table, SCM obj, SCM dflt)); -extern SCM scm_hash_set_x SCM_P ((SCM table, SCM obj, SCM val)); -extern SCM scm_hash_remove_x SCM_P ((SCM table, SCM obj)); -extern SCM scm_hashx_get_handle SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj)); -extern SCM scm_hashx_create_handle_x SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM init)); -extern SCM scm_hashx_ref SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt)); -extern SCM scm_hashx_set_x SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM val)); -extern SCM scm_hashx_remove_x SCM_P ((SCM hash, SCM assoc, SCM del, SCM table, SCM obj)); -extern void scm_init_hashtab SCM_P ((void)); - -#endif /* HASHTABH */ diff --git a/libguile/inet_aton.c b/libguile/inet_aton.c deleted file mode 100644 index 1d02af5e5..000000000 --- a/libguile/inet_aton.c +++ /dev/null @@ -1,157 +0,0 @@ -/* - * Copyright (c) 1983, 1990, 1993 - * The Regents of the University of California. All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. All advertising materials mentioning features or use of this software - * must display the following acknowledgement: - * This product includes software developed by the University of - * California, Berkeley and its contributors. - * 4. Neither the name of the University nor the names of its contributors - * may be used to endorse or promote products derived from this software - * without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - * SUCH DAMAGE. - */ - -#if defined(LIBC_SCCS) && !defined(lint) -static char sccsid[] = "@(#)inet_addr.c 8.1 (Berkeley) 6/17/93"; -#endif /* LIBC_SCCS and not lint */ - -#include <ctype.h> - -#include <sys/param.h> -#include <netinet/in.h> -#include <arpa/inet.h> - -#if 0 - -/* - * Ascii internet address interpretation routine. - * The value returned is in network order. - */ -u_long -inet_addr(cp) - register const char *cp; -{ - struct in_addr val; - - if (inet_aton(cp, &val)) - return (val.s_addr); - return (INADDR_NONE); -} - -#endif - -/* - * Check whether "cp" is a valid ascii representation - * of an Internet address and convert to a binary address. - * Returns 1 if the address is valid, 0 if not. - * This replaces inet_addr, the return value from which - * cannot distinguish between failure and a local broadcast address. - */ -int -inet_aton(cp, addr) - register const char *cp; - struct in_addr *addr; -{ - register unsigned long val; - register int base, n; - register char c; - unsigned int parts[4]; - register unsigned int *pp = parts; - - for (;;) { - /* - * Collect number up to ``.''. - * Values are specified as for C: - * 0x=hex, 0=octal, other=decimal. - */ - val = 0; base = 10; - if (*cp == '0') { - if (*++cp == 'x' || *cp == 'X') - base = 16, cp++; - else - base = 8; - } - while ((c = *cp) != '\0') { - if (isascii(c) && isdigit(c)) { - val = (val * base) + (c - '0'); - cp++; - continue; - } - if (base == 16 && isascii(c) && isxdigit(c)) { - val = (val << 4) + - (c + 10 - (islower(c) ? 'a' : 'A')); - cp++; - continue; - } - break; - } - if (*cp == '.') { - /* - * Internet format: - * a.b.c.d - * a.b.c (with c treated as 16-bits) - * a.b (with b treated as 24 bits) - */ - if (pp >= parts + 3 || val > 0xff) - return (0); - *pp++ = val, cp++; - } else - break; - } - /* - * Check for trailing characters. - */ - if (*cp && (!isascii(*cp) || !isspace(*cp))) - return (0); - /* - * Concoct the address according to - * the number of parts specified. - */ - n = pp - parts + 1; - switch (n) { - - case 1: /* a -- 32 bits */ - break; - - case 2: /* a.b -- 8.24 bits */ - if (val > 0xffffff) - return (0); - val |= parts[0] << 24; - break; - - case 3: /* a.b.c -- 8.8.16 bits */ - if (val > 0xffff) - return (0); - val |= (parts[0] << 24) | (parts[1] << 16); - break; - - case 4: /* a.b.c.d -- 8.8.8.8 bits */ - if (val > 0xff) - return (0); - val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8); - break; - } - if (addr) - addr->s_addr = htonl(val); - return (1); -} diff --git a/libguile/init.c b/libguile/init.c deleted file mode 100644 index edbffd208..000000000 --- a/libguile/init.c +++ /dev/null @@ -1,454 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -/* Everybody has an init function. */ -#include "alist.h" -#include "append.h" -#include "arbiters.h" -#include "async.h" -#include "backtrace.h" -#include "boolean.h" -#include "chars.h" -#include "continuations.h" -#ifdef DEBUG_EXTENSIONS -#include "debug.h" -#endif -#include "dynl.h" -#include "dynwind.h" -#include "eq.h" -#include "error.h" -#include "eval.h" -#include "fdsocket.h" -#include "feature.h" -#include "filesys.h" -#include "fports.h" -#include "gc.h" -#include "gdbint.h" -#include "gsubr.h" -#include "hash.h" -#include "hashtab.h" -#include "ioext.h" -#include "kw.h" -#include "list.h" -#include "load.h" -#include "mallocs.h" -#include "mbstrings.h" -#include "numbers.h" -#include "objprop.h" -#include "options.h" -#include "pairs.h" -#include "ports.h" -#include "posix.h" -#include "print.h" -#include "procprop.h" -#include "procs.h" -#include "ramap.h" -#include "read.h" -#include "scmsigs.h" -#include "sequences.h" -#include "simpos.h" -#include "smob.h" -#include "socket.h" -#include "srcprop.h" -#include "stackchk.h" -#include "stacks.h" -#include "stime.h" -#include "strings.h" -#include "strop.h" -#include "strorder.h" -#include "strports.h" -#include "struct.h" -#include "symbols.h" -#include "tag.h" -#include "throw.h" -#include "unif.h" -#include "variable.h" -#include "vectors.h" -#include "version.h" -#include "vports.h" -#include "weaks.h" - -#include "init.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - -static void scm_start_stack SCM_P ((void *base)); -static void scm_restart_stack SCM_P ((void * base)); - -static void -scm_start_stack (base) - void * base; -{ - SCM root; - - root = scm_permanent_object (scm_make_root (SCM_UNDEFINED)); - scm_set_root (SCM_ROOT_STATE (root)); - scm_stack_base = base; - - scm_exitval = SCM_BOOL_F; /* vestigial */ - - scm_top_level_lookup_closure_var = SCM_BOOL_F; - scm_system_transformer = SCM_BOOL_F; - - /* Create an object to hold the root continuation. - */ - SCM_NEWCELL (scm_rootcont); - SCM_SETJMPBUF (scm_rootcont, scm_must_malloc ((long) sizeof (scm_contregs), - "continuation")); - SCM_SETCAR (scm_rootcont, scm_tc7_contin); - SCM_SEQ (scm_rootcont) = 0; - /* The root continuation if further initialized by scm_restart_stack. */ - - /* Create the look-aside stack for variables that are shared between - * captured continuations. - */ - scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), - SCM_UNDEFINED, SCM_UNDEFINED); - /* The continuation stack is further initialized by scm_restart_stack. */ - - /* The remainder of stack initialization is factored out to another - * function so that if this stack is ever exitted, it can be - * re-entered using scm_restart_stack. */ - scm_restart_stack (base); -} - - -static void -scm_restart_stack (base) - void * base; -{ - scm_dynwinds = SCM_EOL; - SCM_DYNENV (scm_rootcont) = SCM_EOL; - SCM_THROW_VALUE (scm_rootcont) = SCM_EOL; -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0; -#endif - SCM_BASE (scm_rootcont) = base; - scm_continuation_stack_ptr = SCM_MAKINUM (0); -} - -#if 0 -static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define "; - - -static void fixconfig SCM_P ((char *s1, char *s2, int s)); - -static void -fixconfig (s1, s2, s) - char *s1; - char *s2; - int s; -{ - fputs (s1, stderr); - fputs (s2, stderr); - fputs ("\nin ", stderr); - fputs (s ? "setjump" : "scmfig", stderr); - fputs (".h and recompile scm\n", stderr); - exit (1); -} - - -static void check_config SCM_P ((void)); - -static void -check_config () -{ - scm_sizet j; - - j = HEAP_SEG_SIZE; - if (HEAP_SEG_SIZE != j) - fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0); - -#ifdef SCM_SINGLES - if (sizeof (float) != sizeof (long)) - fixconfig (remsg, "SCM_SINGLES", 0); -#endif /* def SCM_SINGLES */ - - -#ifdef SCM_BIGDIG - if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long)) - fixconfig (remsg, "SCM_BIGDIG", 0); -#ifndef SCM_DIGSTOOBIG - if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long)) - fixconfig (addmsg, "SCM_DIGSTOOBIG", 0); -#endif -#endif - -#ifdef SCM_STACK_GROWS_UP - if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0) - fixconfig (remsg, "SCM_STACK_GROWS_UP", 1); -#else - if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0) - fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1); -#endif -} -#endif - - - -/* initializing standard and current I/O ports */ - -/* Create standard ports from stdio stdin, stdout, and stderr. */ -static void -scm_init_standard_ports () -{ - /* I'm not sure why this should be unbuffered when coming from a - tty; isn't line buffering more common? */ - scm_def_inp = scm_stdio_to_port (stdin, - (isatty (fileno (stdin)) ? "r0" : "r"), - "standard input"); - scm_def_outp = scm_stdio_to_port (stdout, "w", "standard output"); - scm_def_errp = scm_stdio_to_port (stderr, "w", "standard error"); - - scm_cur_inp = scm_def_inp; - scm_cur_outp = scm_def_outp; - scm_cur_errp = scm_def_errp; -} - - - -#ifdef _UNICOS -typedef int setjmp_type; -#else -typedef long setjmp_type; -#endif - -static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base, - int argc, char **argv, - void (*main_func) (void *closure, - int argc, - char **argv), - void *closure)); - - -/* Fire up the Guile Scheme interpreter. - - Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV. MAIN_FUNC - should do all the work of the program (initializing other packages, - reading user input, etc.) before returning. When MAIN_FUNC - returns, call exit (0); this function never returns. If you want - some other exit value, MAIN_FUNC may call exit itself. - - scm_boot_guile arranges for program-arguments to return the strings - given by ARGC and ARGV. If MAIN_FUNC modifies ARGC/ARGV, should - call scm_set_program_arguments with the final list, so Scheme code - will know which arguments have been processed. - - Why must the caller do all the real work from MAIN_FUNC? The - garbage collector assumes that all local variables of type SCM will - be above scm_boot_guile's stack frame on the stack. If you try to - manipulate SCM values after this function returns, it's the luck of - the draw whether the GC will be able to find the objects you - allocate. So, scm_boot_guile function exits, rather than - returning, to discourage people from making that mistake. */ - - -void -scm_boot_guile (argc, argv, main_func, closure) - int argc; - char ** argv; - void (*main_func) (); - void *closure; -{ - /* The garbage collector uses the address of this variable as one - end of the stack, and the address of one of its own local - variables as the other end. */ - SCM_STACKITEM dummy; - - return scm_boot_guile_1 (&dummy, argc, argv, main_func, closure); -} - -/* Record here whether SCM_BOOT_GUILE_1 has already been called. This - variable is now here and not inside SCM_BOOT_GUILE_1 so that one - can tweak it. This is necessary for unexec to work. (Hey, "1-live" - is the name of a local radiostation...) */ - -int scm_boot_guile_1_live = 0; - -static void -scm_boot_guile_1 (base, argc, argv, main_func, closure) - SCM_STACKITEM *base; - int argc; - char **argv; - void (*main_func) (); - void *closure; -{ - static int initialized = 0; - /* static int live = 0; */ - setjmp_type setjmp_val; - - /* This function is not re-entrant. */ - if (scm_boot_guile_1_live) - abort (); - - scm_boot_guile_1_live = 1; - - scm_ints_disabled = 1; - scm_block_gc = 1; - - if (initialized) - { - scm_restart_stack (base); - } - else - { - scm_ports_prehistory (); - scm_smob_prehistory (); - scm_tables_prehistory (); - scm_init_storage (0); - scm_init_root (); -#ifdef USE_THREADS - scm_init_threads (base); -#endif - scm_start_stack (base); - scm_init_gsubr (); - scm_init_feature (); - scm_init_alist (); - scm_init_append (); - scm_init_arbiters (); - scm_init_async (); - scm_init_backtrace (); - scm_init_boolean (); - scm_init_chars (); - scm_init_continuations (); - scm_init_dynwind (); - scm_init_eq (); - scm_init_error (); - scm_init_fdsocket (); - scm_init_fports (); - scm_init_filesys (); - scm_init_gc (); - scm_init_gdbint (); - scm_init_hash (); - scm_init_hashtab (); - scm_init_ioext (); - scm_init_kw (); - scm_init_list (); - scm_init_mallocs (); - scm_init_numbers (); - scm_init_objprop (); -#if DEBUG_EXTENSIONS - /* Excluding this until it's really needed makes the binary - * smaller after linking. */ - scm_init_options (); -#endif - scm_init_pairs (); - scm_init_ports (); - scm_init_posix (); - scm_init_procs (); - scm_init_procprop (); - scm_init_scmsigs (); - scm_init_socket (); -#ifdef DEBUG_EXTENSIONS - scm_init_srcprop (); -#endif - scm_init_stackchk (); - scm_init_struct (); /* Requires struct */ - scm_init_stacks (); - scm_init_strports (); - scm_init_symbols (); - scm_init_tag (); - scm_init_load (); - scm_init_print (); /* Requires struct */ - scm_init_read (); - scm_init_sequences (); - scm_init_stime (); - scm_init_strings (); - scm_init_strorder (); - scm_init_mbstrings (); - scm_init_strop (); - scm_init_throw (); - scm_init_variable (); - scm_init_vectors (); - scm_init_version (); - scm_init_weaks (); - scm_init_vports (); - scm_init_eval (); -#ifdef DEBUG_EXTENSIONS - scm_init_debug (); /* Requires macro smobs */ -#endif - scm_init_ramap (); - scm_init_unif (); - scm_init_simpos (); - scm_init_load_path (); - scm_init_standard_ports (); - scm_init_dynamic_linking (); - initialized = 1; - } - - scm_block_gc = 0; /* permit the gc to run */ - /* ints still disabled */ - -#ifdef STACK_CHECKING - scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; -#endif - - setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont)); - if (!setjmp_val) - { - scm_init_signals (); - - scm_set_program_arguments (argc, argv, 0); - (*main_func) (closure, argc, argv); - } - - scm_restore_signals (); - - /* This tick gives any pending - * asyncs a chance to run. This must be done after - * the call to scm_restore_signals. - */ - SCM_ASYNC_TICK; - - /* If the caller doesn't want this, they should return from - main_func themselves. */ - exit (0); -} diff --git a/libguile/init.h b/libguile/init.h deleted file mode 100644 index 97fb5e182..000000000 --- a/libguile/init.h +++ /dev/null @@ -1,56 +0,0 @@ -/* classes: h_files */ - -#ifndef INITH -#define INITH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -extern void scm_boot_guile SCM_P ((int argc, char **argv, - void (*main_func) (void *closure, - int argc, - char **argv), - void *closure)); - -#endif /* INITH */ diff --git a/libguile/ioext.c b/libguile/ioext.c deleted file mode 100644 index 37b8bdc34..000000000 --- a/libguile/ioext.c +++ /dev/null @@ -1,458 +0,0 @@ -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - -#include <stdio.h> -#include "fd.h" -#include "_scm.h" -#include "fports.h" - -#include "ioext.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - -SCM_PROC (s_sys_ftell, "ftell", 1, 0, 0, scm_sys_ftell); - -SCM -scm_sys_ftell (port) - SCM port; -{ - long pos; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_ftell); - SCM_SYSCALL (pos = ftell ((FILE *)SCM_STREAM (port))); - if (pos < 0) - scm_syserror (s_sys_ftell); - if (pos > 0 && SCM_CRDYP (port)) - pos--; - return scm_long2num (pos); -} - - - -SCM_PROC (s_sys_fseek, "fseek", 3, 0, 0, scm_sys_fseek); - -SCM -scm_sys_fseek (port, offset, whence) - SCM port; - SCM offset; - SCM whence; -{ - int rv; - long loff; - - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fseek); - loff = scm_num2long (offset, (char *)SCM_ARG2, s_sys_fseek); - SCM_ASSERT (SCM_INUMP (whence) && (SCM_INUM (whence) < 3) && (SCM_INUM (whence) >= 0), - whence, SCM_ARG3, s_sys_fseek); - - SCM_CLRDY (port); /* Clear ungetted char */ - /* Values of whence are interned in scm_init_ioext. */ - rv = fseek ((FILE *)SCM_STREAM (port), loff, SCM_INUM (whence)); - if (rv != 0) - scm_syserror (s_sys_fseek); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_sys_freopen, "freopen", 3, 0, 0, scm_sys_freopen); - -SCM -scm_sys_freopen (filename, modes, port) - SCM filename; - SCM modes; - SCM port; -{ - FILE *f; - SCM_ASSERT (SCM_NIMP (filename) && SCM_STRINGP (filename), filename, SCM_ARG1, s_sys_freopen); - SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_freopen); - SCM_DEFER_INTS; - SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, SCM_ARG3, s_sys_freopen); - SCM_SYSCALL (f = freopen (SCM_CHARS (filename), SCM_CHARS (modes), (FILE *)SCM_STREAM (port))); - if (!f) - { - SCM p; - p = port; - port = SCM_MAKINUM (errno); - SCM_SETAND_CAR (p, ~SCM_OPN); - scm_remove_from_port_table (p); - } - else - { - SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))); - SCM_SETSTREAM (port, (SCM)f); - SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))); - if (SCM_BUF0 & SCM_CAR (port)) - scm_setbuf0 (port); - } - SCM_ALLOW_INTS; - return port; -} - - - -SCM_PROC (s_sys_duplicate_port, "duplicate-port", 2, 0, 0, scm_sys_duplicate_port); - -SCM -scm_sys_duplicate_port (oldpt, modes) - SCM oldpt; - SCM modes; -{ - int oldfd; - int newfd; - FILE *f; - SCM newpt; - SCM_ASSERT (SCM_NIMP (oldpt) && SCM_OPPORTP (oldpt), oldpt, SCM_ARG1, s_sys_duplicate_port); - SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_duplicate_port); - SCM_NEWCELL (newpt); - SCM_DEFER_INTS; - oldfd = fileno ((FILE *)SCM_STREAM (oldpt)); - if (oldfd == -1) - scm_syserror (s_sys_duplicate_port); - SCM_SYSCALL (newfd = dup (oldfd)); - if (newfd == -1) - scm_syserror (s_sys_duplicate_port); - f = fdopen (newfd, SCM_CHARS (modes)); - if (!f) - { - SCM_SYSCALL (close (newfd)); - scm_syserror (s_sys_duplicate_port); - } - { - struct scm_port_table * pt; - pt = scm_add_to_port_table (newpt); - SCM_SETPTAB_ENTRY (newpt, pt); - SCM_SETCAR (newpt, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))); - if (SCM_BUF0 & SCM_CAR (newpt)) - scm_setbuf0 (newpt); - SCM_SETSTREAM (newpt, (SCM)f); - SCM_PTAB_ENTRY (newpt)->file_name = SCM_PTAB_ENTRY (oldpt)->file_name; - } - SCM_ALLOW_INTS; - return newpt; -} - - - -SCM_PROC (s_sys_redirect_port, "redirect-port", 2, 0, 0, scm_sys_redirect_port); - -SCM -scm_sys_redirect_port (into_pt, from_pt) - SCM into_pt; - SCM from_pt; -{ - int ans, oldfd, newfd; - SCM_DEFER_INTS; - SCM_ASSERT (SCM_NIMP (into_pt) && SCM_OPPORTP (into_pt), into_pt, SCM_ARG1, s_sys_redirect_port); - SCM_ASSERT (SCM_NIMP (from_pt) && SCM_OPPORTP (from_pt), from_pt, SCM_ARG2, s_sys_redirect_port); - oldfd = fileno ((FILE *)SCM_STREAM (into_pt)); - if (oldfd == -1) - scm_syserror (s_sys_redirect_port); - newfd = fileno ((FILE *)SCM_STREAM (from_pt)); - if (newfd == -1) - scm_syserror (s_sys_redirect_port); - SCM_SYSCALL (ans = dup2 (oldfd, newfd)); - if (ans == -1) - scm_syserror (s_sys_redirect_port); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_sys_fileno, "fileno", 1, 0, 0, scm_sys_fileno); - -SCM -scm_sys_fileno (port) - SCM port; -{ - int fd; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fileno); - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1) - scm_syserror (s_sys_fileno); - return SCM_MAKINUM (fd); -} - -SCM_PROC (s_sys_isatty, "isatty?", 1, 0, 0, scm_sys_isatty_p); - -SCM -scm_sys_isatty_p (port) - SCM port; -{ - int rv; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_isatty); - rv = fileno ((FILE *)SCM_STREAM (port)); - if (rv == -1) - scm_syserror (s_sys_isatty); - rv = isatty (rv); - return rv ? SCM_BOOL_T : SCM_BOOL_F; -} - - - -SCM_PROC (s_sys_fdopen, "fdopen", 2, 0, 0, scm_sys_fdopen); - -SCM -scm_sys_fdopen (fdes, modes) - SCM fdes; - SCM modes; -{ - FILE *f; - SCM port; - struct scm_port_table * pt; - - SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_sys_fdopen); - SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_fdopen); - SCM_NEWCELL (port); - SCM_DEFER_INTS; - f = fdopen (SCM_INUM (fdes), SCM_CHARS (modes)); - if (f == NULL) - scm_syserror (s_sys_fdopen); - pt = scm_add_to_port_table (port); - SCM_SETPTAB_ENTRY (port, pt); - SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes))); - if (SCM_BUF0 & SCM_CAR (port)) - scm_setbuf0 (port); - SCM_SETSTREAM (port, (SCM)f); - SCM_ALLOW_INTS; - return port; -} - - - -/* Move a port's underlying file descriptor to a given value. - * Returns #f if fdes is already the given value. - * #t if fdes moved. - * MOVE->FDES is implemented in Scheme and calls this primitive. - */ -SCM_PROC (s_sys_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, scm_sys_primitive_move_to_fdes); - -SCM -scm_sys_primitive_move_to_fdes (port, fd) - SCM port; - SCM fd; -{ - FILE *stream; - int old_fd; - int new_fd; - int rv; - - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_primitive_move_to_fdes); - SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_sys_primitive_move_to_fdes); - SCM_DEFER_INTS; - stream = (FILE *)SCM_STREAM (port); - old_fd = fileno (stream); - new_fd = SCM_INUM (fd); - if (old_fd == new_fd) - { - SCM_ALLOW_INTS; - return SCM_BOOL_F; - } - scm_evict_ports (new_fd); - rv = dup2 (old_fd, new_fd); - if (rv == -1) - scm_syserror (s_sys_primitive_move_to_fdes); - scm_setfileno (stream, new_fd); - SCM_SYSCALL (close (old_fd)); - SCM_ALLOW_INTS; - return SCM_BOOL_T; -} - - -void -scm_setfileno (fs, fd) - FILE *fs; - int fd; -{ -#ifdef SET_FILE_FD_FIELD - SET_FILE_FD_FIELD(fs, fd); -#else - Configure could not guess the name of the correct field in a FILE *. - - This function needs to be ported to your system. - - SET_FILE_FD_FIELD should change the descriptor refered to by a stdio - stream, and nothing else. - - The way to port this file is to add cases to configure.in. Search - that file for "SET_FILE_FD_FIELD" and follow the examples there. -#endif -} - -/* Move ports with the specified file descriptor to new descriptors, - * reseting the revealed count to 0. - * Should be called with SCM_DEFER_INTS active. - */ - -void -scm_evict_ports (fd) - int fd; -{ - int i; - - for (i = 0; i < scm_port_table_size; i++) - { - if (SCM_FPORTP (scm_port_table[i]->port) - && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == fd) - { - scm_setfileno ((FILE *)SCM_STREAM (scm_port_table[i]->port), dup (fd)); - scm_set_port_revealed_x (scm_port_table[i]->port, SCM_MAKINUM (0)); - } - } -} - -/* Return a list of ports using a given file descriptor. */ -SCM_PROC(s_fdes_to_ports, "fdes->ports", 1, 0, 0, scm_fdes_to_ports); - -SCM -scm_fdes_to_ports (fd) - SCM fd; -{ - SCM result = SCM_EOL; - int int_fd; - int i; - - SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG1, s_fdes_to_ports); - int_fd = SCM_INUM (fd); - - SCM_DEFER_INTS; - for (i = 0; i < scm_port_table_size; i++) - { - if (SCM_FPORTP (scm_port_table[i]->port) - && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == int_fd) - result = scm_cons (scm_port_table[i]->port, result); - } - SCM_ALLOW_INTS; - return result; -} - - -void -scm_init_ioext () -{ - /* fseek() symbols. */ - scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET)); - scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR)); - scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END)); - - /* File type/permission bits. */ -#ifdef S_IRUSR - scm_sysintern ("S_IRUSR", SCM_MAKINUM (S_IRUSR)); -#endif -#ifdef S_IWUSR - scm_sysintern ("S_IWUSR", SCM_MAKINUM (S_IWUSR)); -#endif -#ifdef S_IXUSR - scm_sysintern ("S_IXUSR", SCM_MAKINUM (S_IXUSR)); -#endif -#ifdef S_IRWXU - scm_sysintern ("S_IRWXU", SCM_MAKINUM (S_IRWXU)); -#endif - -#ifdef S_IRGRP - scm_sysintern ("S_IRGRP", SCM_MAKINUM (S_IRGRP)); -#endif -#ifdef S_IWGRP - scm_sysintern ("S_IWGRP", SCM_MAKINUM (S_IWGRP)); -#endif -#ifdef S_IXGRP - scm_sysintern ("S_IXGRP", SCM_MAKINUM (S_IXGRP)); -#endif -#ifdef S_IRWXG - scm_sysintern ("S_IRWXG", SCM_MAKINUM (S_IRWXG)); -#endif - -#ifdef S_IROTH - scm_sysintern ("S_IROTH", SCM_MAKINUM (S_IROTH)); -#endif -#ifdef S_IWOTH - scm_sysintern ("S_IWOTH", SCM_MAKINUM (S_IWOTH)); -#endif -#ifdef S_IXOTH - scm_sysintern ("S_IXOTH", SCM_MAKINUM (S_IXOTH)); -#endif -#ifdef S_IRWXO - scm_sysintern ("S_IRWXO", SCM_MAKINUM (S_IRWXO)); -#endif - -#ifdef S_ISUID - scm_sysintern ("S_ISUID", SCM_MAKINUM (S_ISUID)); -#endif -#ifdef S_ISGID - scm_sysintern ("S_ISGID", SCM_MAKINUM (S_ISGID)); -#endif -#ifdef S_ISVTX - scm_sysintern ("S_ISVTX", SCM_MAKINUM (S_ISVTX)); -#endif - -#ifdef S_IFMT - scm_sysintern ("S_IFMT", SCM_MAKINUM (S_IFMT)); -#endif -#ifdef S_IFDIR - scm_sysintern ("S_IFDIR", SCM_MAKINUM (S_IFDIR)); -#endif -#ifdef S_IFCHR - scm_sysintern ("S_IFCHR", SCM_MAKINUM (S_IFCHR)); -#endif -#ifdef S_IFBLK - scm_sysintern ("S_IFBLK", SCM_MAKINUM (S_IFBLK)); -#endif -#ifdef S_IFREG - scm_sysintern ("S_IFREG", SCM_MAKINUM (S_IFREG)); -#endif -#ifdef S_IFLNK - scm_sysintern ("S_IFLNK", SCM_MAKINUM (S_IFLNK)); -#endif -#ifdef S_IFSOCK - scm_sysintern ("S_IFSOCK", SCM_MAKINUM (S_IFSOCK)); -#endif -#ifdef S_IFIFO - scm_sysintern ("S_IFIFO", SCM_MAKINUM (S_IFIFO)); -#endif -#include "ioext.x" -} - diff --git a/libguile/ioext.h b/libguile/ioext.h deleted file mode 100644 index e026a1f23..000000000 --- a/libguile/ioext.h +++ /dev/null @@ -1,68 +0,0 @@ -/* classes: h_files */ - -#ifndef IOEXTH -#define IOEXTH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - -extern SCM scm_sys_ftell SCM_P ((SCM port)); -extern SCM scm_sys_fseek SCM_P ((SCM port, SCM offset, SCM whence)); -extern SCM scm_sys_freopen SCM_P ((SCM filename, SCM modes, SCM port)); -extern SCM scm_sys_duplicate_port SCM_P ((SCM oldpt, SCM modes)); -extern SCM scm_sys_redirect_port SCM_P ((SCM into_pt, SCM from_pt)); -extern SCM scm_sys_fileno SCM_P ((SCM port)); -extern SCM scm_sys_isatty_p SCM_P ((SCM port)); -extern SCM scm_sys_fdopen SCM_P ((SCM fdes, SCM modes)); -extern SCM scm_sys_primitive_move_to_fdes SCM_P ((SCM port, SCM fd)); -extern void scm_setfileno SCM_P ((FILE *fs, int fd)); -extern void scm_evict_ports SCM_P ((int fd)); -extern SCM scm_fdes_to_ports SCM_P ((SCM fd)); -extern void scm_init_ioext SCM_P ((void)); - -#endif /* IOEXTH */ diff --git a/libguile/kw.c b/libguile/kw.c deleted file mode 100644 index 76ca88050..000000000 --- a/libguile/kw.c +++ /dev/null @@ -1,148 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "mbstrings.h" -#include "smob.h" - -#include "kw.h" - - - -static scm_sizet free_kw SCM_P ((SCM obj)); - -static scm_sizet -free_kw (obj) - SCM obj; -{ - return 0; -} - - -static int prin_kw SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prin_kw (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, ":", port); - scm_gen_puts((SCM_MB_STRINGP(SCM_CDR (exp)) - ? scm_mb_string - : scm_regular_string), - 1 + SCM_CHARS (SCM_CDR (exp)), - port); - return 1; -} - -int scm_tc16_kw; - -static scm_smobfuns kw_smob = {scm_markcdr, free_kw, prin_kw, 0}; - - - -SCM_PROC (s_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, scm_make_keyword_from_dash_symbol); - -SCM -scm_make_keyword_from_dash_symbol (symbol) - SCM symbol; -{ - SCM vcell; - - SCM_ASSERT (SCM_NIMP (symbol) && SCM_SYMBOLP(symbol) && ('-' == SCM_CHARS(symbol)[0]), - symbol, SCM_ARG1, s_make_keyword_from_dash_symbol); - - - SCM_DEFER_INTS; - vcell = scm_sym2ovcell_soft (symbol, scm_kw_obarray); - if (vcell == SCM_BOOL_F) - { - SCM kw; - SCM_NEWCELL(kw); - SCM_SETCAR (kw, (SCM)scm_tc16_kw); - SCM_SETCDR (kw, symbol); - scm_intern_symbol (scm_kw_obarray, symbol); - vcell = scm_sym2ovcell_soft (symbol, scm_kw_obarray); - SCM_SETCDR (vcell, kw); - } - SCM_ALLOW_INTS; - return SCM_CDR (vcell); -} - -SCM_PROC(s_keyword_p, "keyword?", 1, 0, 0, scm_keyword_p); - -SCM -scm_keyword_p (obj) - SCM obj; -{ - return ( (SCM_NIMP(obj) && SCM_KEYWORDP (obj)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - -SCM_PROC(s_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0, scm_keyword_dash_symbol); - -SCM -scm_keyword_dash_symbol (kw) - SCM kw; -{ - SCM_ASSERT (SCM_NIMP (kw) && SCM_KEYWORDP (kw), kw, SCM_ARG1, s_keyword_dash_symbol); - return SCM_CDR (kw); -} - - - - - -void -scm_init_kw () -{ - scm_tc16_kw = scm_newsmob (&kw_smob); - scm_kw_obarray = scm_make_vector (SCM_MAKINUM (256), SCM_EOL, SCM_UNDEFINED); -#include "kw.x" -} - diff --git a/libguile/kw.h b/libguile/kw.h deleted file mode 100644 index 89387c5b3..000000000 --- a/libguile/kw.h +++ /dev/null @@ -1,63 +0,0 @@ -/* classes: h_files */ - -#ifndef KWH -#define KWH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern int scm_tc16_kw; -#define SCM_KEYWORDP(X) (SCM_CAR(X) == scm_tc16_kw) -#define SCM_KEYWORDSYM(X) (SCM_CDR(X)) - - - - -extern SCM scm_make_keyword_from_dash_symbol SCM_P ((SCM symbol)); -extern SCM scm_keyword_p SCM_P ((SCM obj)); -extern SCM scm_keyword_dash_symbol SCM_P ((SCM kw)); -extern void scm_init_kw SCM_P ((void)); - -#endif /* KWH */ diff --git a/libguile/libguile.h b/libguile/libguile.h deleted file mode 100644 index 448d2de0a..000000000 --- a/libguile/libguile.h +++ /dev/null @@ -1,131 +0,0 @@ -#ifndef LIBGUILEH -#define LIBGUILEH - -/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - - -#include "libguile/__scm.h" - -/* These files define typedefs used by later files, so they need to - come first. */ -#include "libguile/print.h" -#include "libguile/smob.h" -#include "libguile/pairs.h" - -#include "libguile/alist.h" -#include "libguile/append.h" -#include "libguile/arbiters.h" -#include "libguile/async.h" -#include "libguile/boolean.h" -#include "libguile/chars.h" -#include "libguile/continuations.h" -#ifdef DEBUG_EXTENSIONS -#include "libguile/backtrace.h" -#include "libguile/debug.h" -#include "libguile/stacks.h" -#endif -#include "libguile/dynwind.h" -#include "libguile/eq.h" -#include "libguile/error.h" -#include "libguile/eval.h" -#include "libguile/extchrs.h" -#include "libguile/fdsocket.h" -#include "libguile/feature.h" -#include "libguile/filesys.h" -#include "libguile/fports.h" -#include "libguile/gc.h" -#include "libguile/gdbint.h" -#include "libguile/genio.h" -#include "libguile/gsubr.h" -#include "libguile/hash.h" -#include "libguile/hashtab.h" -#include "libguile/init.h" -#include "libguile/ioext.h" -#include "libguile/kw.h" -#include "libguile/libpath.h" -#include "libguile/list.h" -#include "libguile/load.h" -#include "libguile/mallocs.h" -#include "libguile/markers.h" -#include "libguile/mbstrings.h" -#include "libguile/numbers.h" -#include "libguile/objprop.h" -#include "libguile/options.h" -#include "libguile/ports.h" -#include "libguile/posix.h" -#include "libguile/procprop.h" -#include "libguile/procs.h" -#include "libguile/ramap.h" -#include "libguile/read.h" -#include "libguile/root.h" -#include "libguile/scmsigs.h" -#include "libguile/sequences.h" -#include "libguile/simpos.h" -#include "libguile/snarf.h" -#include "libguile/socket.h" -#include "libguile/srcprop.h" -#include "libguile/stackchk.h" -#include "libguile/stime.h" -#include "libguile/strings.h" -#include "libguile/strop.h" -#include "libguile/strorder.h" -#include "libguile/strports.h" -#include "libguile/struct.h" -#include "libguile/symbols.h" -#include "libguile/tag.h" -#include "libguile/tags.h" -#include "libguile/throw.h" -#include "libguile/unif.h" -#include "libguile/variable.h" -#include "libguile/vectors.h" -#include "libguile/version.h" -#include "libguile/vports.h" -#include "libguile/weaks.h" -#ifdef USE_THREADS -#include "libguile/../threads/threads.h" -#endif - - - -#endif /* LIBGUILEH */ diff --git a/libguile/list.c b/libguile/list.c deleted file mode 100644 index 53f5da1fd..000000000 --- a/libguile/list.c +++ /dev/null @@ -1,655 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "eq.h" - -#include "list.h" - -#ifdef __STDC__ -#include <stdarg.h> -#define var_start(x, y) va_start(x, y) -#else -#include <varargs.h> -#define var_start(x, y) va_start(x) -#endif - - -/* creating lists */ - -/* SCM_P won't help us deal with varargs here. */ -#ifdef __STDC__ -SCM -scm_listify (SCM elt, ...) -#else -SCM -scm_listify (elt, va_alist) - SCM elt; - va_dcl -#endif -{ - va_list foo; - SCM answer; - SCM *pos; - - var_start (foo, elt); - answer = SCM_EOL; - pos = &answer; - while (elt != SCM_UNDEFINED) - { - *pos = scm_cons (elt, SCM_EOL); - pos = SCM_CDRLOC (*pos); - elt = va_arg (foo, SCM); - } - return answer; -} - - -SCM_PROC(s_list, "list", 0, 0, 1, scm_list); -SCM -scm_list(objs) - SCM objs; -{ - return objs; -} - - - - -/* general questions about lists --- null?, list?, length, etc. */ - -SCM_PROC(s_null_p, "null?", 1, 0, 0, scm_null_p); -SCM -scm_null_p(x) - SCM x; -{ - return SCM_NULLP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_list_p, "list?", 1, 0, 0, scm_list_p); -SCM -scm_list_p(x) - SCM x; -{ - if (scm_ilength(x)<0) - return SCM_BOOL_F; - else - return SCM_BOOL_T; -} - - -/* Return the length of SX, or -1 if it's not a proper list. - This uses the "tortoise and hare" algorithm to detect "infinitely - long" lists (i.e. lists with cycles in their cdrs), and returns -1 - if it does find one. */ -long -scm_ilength(sx) - SCM sx; -{ - register long i = 0; - register SCM tortoise = sx; - register SCM hare = sx; - - do { - if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1; - if SCM_NCONSP(hare) return -1; - hare = SCM_CDR(hare); - i++; - if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1; - if SCM_NCONSP(hare) return -1; - hare = SCM_CDR(hare); - i++; - /* For every two steps the hare takes, the tortoise takes one. */ - tortoise = SCM_CDR(tortoise); - } - while (hare != tortoise); - - /* If the tortoise ever catches the hare, then the list must contain - a cycle. */ - return -1; -} - -SCM_PROC(s_list_length, "list-length", 1, 0, 0, scm_list_length); -SCM -scm_list_length(x) - SCM x; -{ - int i; - i = scm_ilength(x); - SCM_ASSERT(i >= 0, x, SCM_ARG1, s_list_length); - return SCM_MAKINUM (i); -} - - - -/* appending lists */ - -SCM_PROC (s_list_append, "list-append", 0, 0, 1, scm_list_append); -SCM -scm_list_append(args) - SCM args; -{ - SCM res = SCM_EOL; - SCM *lloc = &res, arg; - if SCM_IMP(args) { - SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append); - return res; - } - SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append); - while (1) { - arg = SCM_CAR(args); - args = SCM_CDR(args); - if SCM_IMP(args) { - *lloc = arg; - SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append); - return res; - } - SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append); - for(;SCM_NIMP(arg);arg = SCM_CDR(arg)) { - SCM_ASSERT(SCM_CONSP(arg), arg, SCM_ARGn, s_list_append); - *lloc = scm_cons(SCM_CAR(arg), SCM_EOL); - lloc = SCM_CDRLOC(*lloc); - } - SCM_ASSERT(SCM_NULLP(arg), arg, SCM_ARGn, s_list_append); - } -} - - -SCM_PROC (s_list_append_x, "list-append!", 0, 0, 1, scm_list_append_x); -SCM -scm_list_append_x(args) - SCM args; -{ - SCM arg; - tail: - if SCM_NULLP(args) return SCM_EOL; - arg = SCM_CAR(args); - SCM_ASSERT(SCM_NULLP(arg) || (SCM_NIMP(arg) && SCM_CONSP(arg)), arg, SCM_ARG1, s_list_append_x); - args = SCM_CDR(args); - if SCM_NULLP(args) return arg; - if SCM_NULLP(arg) goto tail; - SCM_SETCDR (scm_last_pair (arg), scm_list_append_x (args)); - return arg; -} - - -SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair); -SCM -scm_last_pair(sx) - SCM sx; -{ - register SCM res = sx; - register SCM x; - - if (SCM_NULLP (sx)) - return SCM_EOL; - - SCM_ASSERT(SCM_NIMP(res) && SCM_CONSP(res), res, SCM_ARG1, s_last_pair); - while (!0) { - x = SCM_CDR(res); - if (SCM_IMP(x) || SCM_NCONSP(x)) return res; - res = x; - x = SCM_CDR(res); - if (SCM_IMP(x) || SCM_NCONSP(x)) return res; - res = x; - sx = SCM_CDR(sx); - SCM_ASSERT(x != sx, sx, SCM_ARG1, s_last_pair); - } -} - - -/* reversing lists */ - -SCM_PROC (s_list_reverse, "list-reverse", 1, 0, 0, scm_list_reverse); -SCM -scm_list_reverse(lst) - SCM lst; -{ - SCM res = SCM_EOL; - SCM p = lst; - for(;SCM_NIMP(p);p = SCM_CDR(p)) { - SCM_ASSERT(SCM_CONSP(p), lst, SCM_ARG1, s_list_reverse); - res = scm_cons(SCM_CAR(p), res); - } - SCM_ASSERT(SCM_NULLP(p), lst, SCM_ARG1, s_list_reverse); - return res; -} - -SCM_PROC (s_list_reverse_x, "list-reverse!", 1, 1, 0, scm_list_reverse_x); -SCM -scm_list_reverse_x (lst, newtail) - SCM lst; - SCM newtail; -{ - SCM old_tail; - if (newtail == SCM_UNDEFINED) - newtail = SCM_EOL; - - loop: - if (!(SCM_NIMP (lst) && SCM_CONSP (lst))) - return lst; - - old_tail = SCM_CDR (lst); - SCM_SETCDR (lst, newtail); - if (SCM_NULLP (old_tail)) - return lst; - - newtail = lst; - lst = old_tail; - goto loop; -} - - - -/* indexing lists by element number */ - -SCM_PROC(s_list_ref, "list-ref", 2, 0, 0, scm_list_ref); -SCM -scm_list_ref(lst, k) - SCM lst; - SCM k; -{ - register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_ref); - i = SCM_INUM(k); - SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_ref); - while (i-- > 0) { - SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } -erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_ref); - return SCM_CAR(lst); -} - -SCM_PROC(s_list_set_x, "list-set!", 3, 0, 0, scm_list_set_x); -SCM -scm_list_set_x(lst, k, val) - SCM lst; - SCM k; - SCM val; -{ - register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_set_x); - i = SCM_INUM(k); - SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_set_x); - while (i-- > 0) { - SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } -erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_set_x); - SCM_SETCAR (lst, val); - return val; -} - - -SCM_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail); -SCM_PROC(s_list_tail, "list-tail", 2, 0, 0, scm_list_tail); -SCM -scm_list_tail(lst, k) - SCM lst; - SCM k; -{ - register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_tail); - i = SCM_INUM(k); - while (i-- > 0) { - SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_tail); - lst = SCM_CDR(lst); - } - return lst; -} - - -SCM_PROC(s_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x); -SCM -scm_list_cdr_set_x(lst, k, val) - SCM lst; - SCM k; - SCM val; -{ - register long i; - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_cdr_set_x); - i = SCM_INUM(k); - SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_cdr_set_x); - while (i-- > 0) { - SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout); - lst = SCM_CDR(lst); - } -erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), - SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_cdr_set_x); - SCM_SETCDR (lst, val); - return val; -} - - - -/* copying lists, perhaps partially */ - -SCM_PROC(s_list_head, "list-head", 2, 0, 0, scm_list_head); -SCM -scm_list_head(lst, k) - SCM lst; - SCM k; -{ - SCM answer; - SCM * pos; - register long i; - - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_head); - answer = SCM_EOL; - pos = &answer; - i = SCM_INUM(k); - while (i-- > 0) - { - SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_head); - *pos = scm_cons (SCM_CAR (lst), SCM_EOL); - pos = SCM_CDRLOC (*pos); - lst = SCM_CDR(lst); - } - return answer; -} - - -SCM_PROC (s_list_copy, "list-copy", 1, 0, 0, scm_list_copy); -SCM -scm_list_copy (lst) - SCM lst; -{ - SCM newlst; - SCM * fill_here; - SCM from_here; - - newlst = SCM_EOL; - fill_here = &newlst; - from_here = lst; - - while (SCM_NIMP (from_here) && SCM_CONSP (from_here)) - { - SCM c; - c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here)); - *fill_here = c; - fill_here = SCM_CDRLOC (c); - from_here = SCM_CDR (from_here); - } - return newlst; -} - - -/* membership tests (memq, memv, etc.) */ - -static void sloppy_mem_check SCM_P ((SCM obj, char * where, char * why)); - -static void -sloppy_mem_check (obj, where, why) - SCM obj; - char * where; - char * why; -{ - SCM_ASSERT ((scm_ilength (obj) >= 0), obj, where, why); -} - - -SCM_PROC (s_sloppy_memq, "sloppy-memq", 2, 0, 0, scm_sloppy_memq); -SCM -scm_sloppy_memq(x, lst) - SCM x; - SCM lst; -{ - for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) - { - if (SCM_CAR(lst)==x) - return lst; - } - return lst; -} - - -SCM_PROC (s_sloppy_memv, "sloppy-memv", 2, 0, 0, scm_sloppy_memv); -SCM -scm_sloppy_memv(x, lst) - SCM x; - SCM lst; -{ - for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) - { - if (SCM_BOOL_F != scm_eqv_p (SCM_CAR(lst), x)) - return lst; - } - return lst; -} - - -SCM_PROC (s_sloppy_member, "sloppy-member", 2, 0, 0, scm_sloppy_member); -SCM -scm_sloppy_member (x, lst) - SCM x; - SCM lst; -{ - for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst)) - { - if (SCM_BOOL_F != scm_equal_p (SCM_CAR(lst), x)) - return lst; - } - return lst; -} - - - -SCM_PROC(s_memq, "memq", 2, 0, 0, scm_memq); -SCM -scm_memq(x, lst) - SCM x; - SCM lst; -{ - SCM answer; - answer = scm_sloppy_memq (x, lst); - sloppy_mem_check (answer, (char *)SCM_ARG2, s_memq); - return (answer == SCM_EOL) ? SCM_BOOL_F : answer; -} - - - -SCM_PROC(s_memv, "memv", 2, 0, 0, scm_memv); -SCM -scm_memv(x, lst) - SCM x; - SCM lst; -{ - SCM answer; - answer = scm_sloppy_memv (x, lst); - sloppy_mem_check (answer, (char *)SCM_ARG2, s_memv); - return (answer == SCM_EOL) ? SCM_BOOL_F : answer; -} - - -SCM_PROC(s_member, "member", 2, 0, 0, scm_member); -SCM -scm_member(x, lst) - SCM x; - SCM lst; -{ - SCM answer; - answer = scm_sloppy_member (x, lst); - sloppy_mem_check (answer, (char *)SCM_ARG2, s_member); - return (answer == SCM_EOL) ? SCM_BOOL_F : answer; -} - - - -/* deleting elements from a list (delq, etc.) */ - -SCM_PROC(s_delq_x, "delq!", 2, 0, 0, scm_delq_x); -SCM -scm_delq_x (item, lst) - SCM item; - SCM lst; -{ - SCM start; - - if (SCM_IMP (lst) || SCM_NCONSP (lst)) - return lst; - - if (SCM_CAR (lst) == item) - return SCM_CDR (lst); - - start = lst; - - while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst))) - { - if (SCM_CAR (SCM_CDR (lst)) == item) - { - SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst))); - return start; - } - lst = SCM_CDR (lst); - } - return start; -} - - -SCM_PROC(s_delv_x, "delv!", 2, 0, 0, scm_delv_x); -SCM -scm_delv_x (item, lst) - SCM item; - SCM lst; -{ - SCM start; - - if (SCM_IMP (lst) || SCM_NCONSP (lst)) - return lst; - - if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (lst), item)) - return SCM_CDR (lst); - - start = lst; - - while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst))) - { - if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (SCM_CDR (lst)), item)) - { - SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst))); - return start; - } - lst = SCM_CDR (lst); - } - return start; -} - - - -SCM_PROC(s_delete_x, "delete!", 2, 0, 0, scm_delete_x); -SCM -scm_delete_x (item, lst) - SCM item; - SCM lst; -{ - SCM start; - - if (SCM_IMP (lst) || SCM_NCONSP (lst)) - return lst; - - if (SCM_BOOL_F != scm_equal_p (SCM_CAR (lst), item)) - return SCM_CDR (lst); - - start = lst; - - while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst))) - { - if (SCM_BOOL_F != scm_equal_p (SCM_CAR (SCM_CDR (lst)), item)) - { - SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst))); - return start; - } - lst = SCM_CDR (lst); - } - return start; -} - - - - - -SCM_PROC (s_delq, "delq", 2, 0, 0, scm_delq); -SCM -scm_delq (item, lst) - SCM item; - SCM lst; -{ - SCM copy; - - copy = scm_list_copy (lst); - return scm_delq_x (item, copy); -} - -SCM_PROC (s_delv, "delv", 2, 0, 0, scm_delv); -SCM -scm_delv (item, lst) - SCM item; - SCM lst; -{ - SCM copy; - - copy = scm_list_copy (lst); - return scm_delv_x (item, copy); -} - -SCM_PROC (s_delete, "delete", 2, 0, 0, scm_delete); -SCM -scm_delete (item, lst) - SCM item; - SCM lst; -{ - SCM copy; - - copy = scm_list_copy (lst); - return scm_delete_x (item, copy); -} - - - -void -scm_init_list () -{ -#include "list.x" -} diff --git a/libguile/list.h b/libguile/list.h deleted file mode 100644 index 82d560673..000000000 --- a/libguile/list.h +++ /dev/null @@ -1,82 +0,0 @@ -/* classes: h_files */ - -#ifndef LISTH -#define LISTH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -extern SCM scm_list_head SCM_P ((SCM lst, SCM k)); -extern SCM scm_listify SCM_P ((SCM elt, ...)); -extern SCM scm_list SCM_P ((SCM objs)); -extern SCM scm_null_p SCM_P ((SCM x)); -extern SCM scm_list_p SCM_P ((SCM x)); -extern long scm_ilength SCM_P ((SCM sx)); -extern SCM scm_list_length SCM_P ((SCM x)); -extern SCM scm_list_append SCM_P ((SCM args)); -extern SCM scm_list_append_x SCM_P ((SCM args)); -extern SCM scm_list_reverse SCM_P ((SCM lst)); -extern SCM scm_list_reverse_x SCM_P ((SCM lst, SCM newtail)); -extern SCM scm_list_ref SCM_P ((SCM lst, SCM k)); -extern SCM scm_list_set_x SCM_P ((SCM lst, SCM k, SCM val)); -extern SCM scm_list_cdr_ref SCM_P ((SCM lst, SCM k)); -extern SCM scm_list_cdr_set_x SCM_P ((SCM lst, SCM k, SCM val)); -extern SCM scm_last_pair SCM_P ((SCM sx)); -extern SCM scm_list_tail SCM_P ((SCM lst, SCM k)); -extern SCM scm_sloppy_memq SCM_P ((SCM x, SCM lst)); -extern SCM scm_sloppy_memv SCM_P ((SCM x, SCM lst)); -extern SCM scm_sloppy_member SCM_P ((SCM x, SCM lst)); -extern SCM scm_memq SCM_P ((SCM x, SCM lst)); -extern SCM scm_memv SCM_P ((SCM x, SCM lst)); -extern SCM scm_member SCM_P ((SCM x, SCM lst)); -extern SCM scm_delq_x SCM_P ((SCM item, SCM lst)); -extern SCM scm_delv_x SCM_P ((SCM item, SCM lst)); -extern SCM scm_delete_x SCM_P ((SCM item, SCM lst)); -extern SCM scm_list_copy SCM_P ((SCM lst)); -extern SCM scm_delq SCM_P ((SCM item, SCM lst)); -extern SCM scm_delv SCM_P ((SCM item, SCM lst)); -extern SCM scm_delete SCM_P ((SCM item, SCM lst)); -extern void scm_init_list SCM_P ((void)); - -#endif /* LISTH */ diff --git a/libguile/load.c b/libguile/load.c deleted file mode 100644 index b9a9fc8cc..000000000 --- a/libguile/load.c +++ /dev/null @@ -1,343 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "libpath.h" -#include "fports.h" -#include "read.h" -#include "eval.h" -#include "throw.h" - -#include "load.h" - -#include <sys/types.h> -#include <sys/stat.h> - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif /* HAVE_UNISTD_H */ - -#ifndef R_OK -#define R_OK 4 -#endif - - -/* Loading a file, given an absolute filename. */ - -/* Hook to run when we load a file, perhaps to announce the fact somewhere. - Applied to the full name of the file. */ -static SCM *scm_loc_load_hook; - -SCM_PROC(s_primitive_load, "primitive-load", 1, 2, 0, scm_primitive_load); -SCM -scm_primitive_load (filename, case_insensitive_p, sharp) - SCM filename; - SCM case_insensitive_p; - SCM sharp; -{ - SCM hook = *scm_loc_load_hook; - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_primitive_load); - SCM_ASSERT (hook == SCM_BOOL_F - || (scm_procedure_p (hook) == SCM_BOOL_T), - hook, "value of %load-hook is neither a procedure nor #f", - s_primitive_load); - - if (hook != SCM_BOOL_F) - scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL); - - { - SCM form, port; - port = scm_open_file (filename, - scm_makfromstr ("r", (scm_sizet) sizeof (char), 0)); - while (1) - { - form = scm_read (port, case_insensitive_p, sharp); - if (SCM_EOF_VAL == form) - break; - scm_eval_x (form); - } - scm_close_port (port); - } - return SCM_UNSPECIFIED; -} - - -/* Builtin path to scheme library files. */ -#ifdef SCM_PKGDATA_DIR -SCM_PROC (s_sys_package_data_dir, "%package-data-dir", 0, 0, 0, scm_sys_package_data_dir); -SCM -scm_sys_package_data_dir () -{ - return scm_makfrom0str (SCM_PKGDATA_DIR); -} -#endif /* SCM_PKGDATA_DIR */ - - -/* Initializing the load path, and searching it. */ - -/* List of names of directories we search for files to load. */ -static SCM *scm_loc_load_path; - -/* List of extensions we try adding to the filenames. */ -static SCM *scm_loc_load_extensions; - -/* Initialize the global variable %load-path, given the value of the - SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the - SCHEME_LOAD_PATH environment variable. */ -void -scm_init_load_path () -{ - SCM path = SCM_EOL; - -#ifdef SCM_LIBRARY_DIR - path = scm_cons2 (scm_makfrom0str (SCM_SITE_DIR), - scm_makfrom0str (SCM_LIBRARY_DIR), - path); -#endif /* SCM_LIBRARY_DIR */ - - { - char *path_string = getenv ("SCHEME_LOAD_PATH"); - - if (path_string && path_string[0] != '\0') - { - char *scan, *elt_end; - - /* Scan backwards from the end of the string, to help - construct the list in the right order. */ - scan = elt_end = path_string + strlen (path_string); - do { - /* Scan back to the beginning of the current element. */ - do scan--; - while (scan >= path_string && *scan != ':'); - path = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0), - path); - elt_end = scan; - } while (scan >= path_string); - } - } - - *scm_loc_load_path = path; -} - - -/* Search %load-path for a directory containing a file named FILENAME. - The file must be readable, and not a directory. - If we find one, return its full filename; otherwise, return #f. - If FILENAME is absolute, return it unchanged. */ -SCM_PROC(s_sys_search_load_path, "%search-load-path", 1, 0, 0, scm_sys_search_load_path); -SCM -scm_sys_search_load_path (filename) - SCM filename; -{ - SCM path = *scm_loc_load_path; - SCM exts = *scm_loc_load_extensions; - char *buf; - int filename_len; - int max_path_len; - int max_ext_len; - - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_sys_search_load_path); - SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list", - s_sys_search_load_path); - SCM_ASSERT (scm_ilength (exts) >= 0, exts, - "load extension list is not a proper list", - s_sys_search_load_path); - filename_len = SCM_ROLENGTH (filename); - - /* If FILENAME is absolute, return it unchanged. */ - if (filename_len >= 1 - && SCM_ROCHARS (filename)[0] == '/') - return filename; - - /* Find the length of the longest element of path. */ - { - SCM walk; - - max_path_len = 0; - for (walk = path; SCM_NIMP (walk); walk = SCM_CDR (walk)) - { - SCM elt = SCM_CAR (walk); - SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt, - "load path is not a list of strings", - s_sys_search_load_path); - if (SCM_LENGTH (elt) > max_path_len) - max_path_len = SCM_LENGTH (elt); - } - } - - /* Find the length of the longest element of the load extensions - list. */ - { - SCM walk; - - max_ext_len = 0; - for (walk = exts; SCM_NIMP (walk); walk = SCM_CDR (walk)) - { - SCM elt = SCM_CAR (walk); - SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt, - "load extension list is not a list of strings", - s_sys_search_load_path); - if (SCM_LENGTH (elt) > max_ext_len) - max_ext_len = SCM_LENGTH (elt); - } - } - - SCM_DEFER_INTS; - - buf = scm_must_malloc (max_path_len + 1 + filename_len + max_ext_len + 1, - s_sys_search_load_path); - - /* Try every path element. At this point, we know it's a proper - list of strings. */ - for (; SCM_NIMP (path); path = SCM_CDR (path)) - { - SCM path_elt = SCM_CAR (path); - - /* Try every extension. At this point, we know it's a proper - list of strings. */ - for (exts = *scm_loc_load_extensions; - SCM_NIMP (exts); - exts = SCM_CDR (exts)) - { - SCM ext_elt = SCM_CAR (exts); - int i; - - /* Concatenate the path name, the filename, and the extension. */ - i = SCM_ROLENGTH (path_elt); - memcpy (buf, SCM_ROCHARS (path_elt), i); - if (i >= 1 && buf[i - 1] != '/') - buf[i++] = '/'; - memcpy (buf + i, SCM_ROCHARS (filename), filename_len); - i += filename_len; - memcpy (buf + i, SCM_ROCHARS (ext_elt), SCM_LENGTH (ext_elt)); - i += SCM_LENGTH (ext_elt); - buf[i] = '\0'; - - { - struct stat mode; - - if (stat (buf, &mode) >= 0 - && ! (mode.st_mode & S_IFDIR) - && access (buf, R_OK) == 0) - { - SCM result = scm_makfromstr (buf, i, 0); - scm_must_free (buf); - SCM_ALLOW_INTS; - return result; - } - } - } - } - - scm_must_free (buf); - SCM_ALLOW_INTS; - return SCM_BOOL_F; -} - - -SCM_PROC(s_primitive_load_path, "primitive-load-path", 1, 2, 0, scm_primitive_load_path); -SCM -scm_primitive_load_path (filename, case_insensitive_p, sharp) - SCM filename; - SCM case_insensitive_p; - SCM sharp; -{ - SCM full_filename; - - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, - SCM_ARG1, s_primitive_load_path); - - full_filename = scm_sys_search_load_path (filename); - - if (SCM_FALSEP (full_filename)) - { - int absolute = (SCM_LENGTH (filename) >= 1 - && SCM_ROCHARS (filename)[0] == '/'); - scm_misc_error (s_primitive_load_path, - (absolute - ? "Unable to load file %S" - : "Unable to find file %S in load path"), - scm_listify (filename, SCM_UNDEFINED)); - } - - return scm_primitive_load (full_filename, case_insensitive_p, sharp); -} - -/* The following function seems trivial - and indeed it is. Its - * existence is motivated by its ability to evaluate expressions - * without copying them first (as is done in "eval"). - */ - -SCM_SYMBOL (scm_end_of_file_key, "end-of-file"); - -SCM_PROC (s_read_and_eval_x, "read-and-eval!", 0, 3, 0, scm_read_and_eval_x); - -SCM -scm_read_and_eval_x (port, case_insensitive_p, sharp) - SCM port; - SCM case_insensitive_p; - SCM sharp; -{ - SCM form = scm_read (port, case_insensitive_p, sharp); - if (form == SCM_EOF_VAL) - scm_ithrow (scm_end_of_file_key, SCM_EOL, 1); - return scm_eval_x (form); -} - - - -void -scm_init_load () -{ - scm_loc_load_path = SCM_CDRLOC(scm_sysintern("%load-path", SCM_EOL)); - scm_loc_load_extensions - = SCM_CDRLOC(scm_sysintern("%load-extensions", - scm_listify (scm_makfrom0str (""), - scm_makfrom0str (".scm"), - SCM_UNDEFINED))); - scm_loc_load_hook = SCM_CDRLOC(scm_sysintern("%load-hook", SCM_BOOL_F)); - -#include "load.x" -} diff --git a/libguile/load.h b/libguile/load.h deleted file mode 100644 index cd5d021bb..000000000 --- a/libguile/load.h +++ /dev/null @@ -1,60 +0,0 @@ -/* classes: h_files */ - -#ifndef LOADH -#define LOADH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - -extern void scm_init_load_path SCM_P ((void)); -extern SCM scm_primitive_load SCM_P ((SCM filename, SCM casep, SCM sharp)); -extern SCM scm_sys_package_data_dir SCM_P ((void)); -extern SCM scm_sys_search_load_path SCM_P ((SCM filename)); -extern SCM scm_primitive_load_path SCM_P ((SCM filename, SCM casep, - SCM sharp)); -extern SCM scm_read_and_eval_x SCM_P ((SCM port, - SCM case_insensitive_p, - SCM sharp)); -extern void scm_init_load SCM_P ((void)); - -#endif /* LOADH */ diff --git a/libguile/mallocs.c b/libguile/mallocs.c deleted file mode 100644 index 4201adca8..000000000 --- a/libguile/mallocs.c +++ /dev/null @@ -1,105 +0,0 @@ -/* classes: src_files */ - -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - */ - - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "smob.h" - -#include "mallocs.h" - -#ifdef HAVE_MALLOC_H -#include <malloc.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - - - - - -static scm_sizet fmalloc SCM_P ((SCM ptr)); - -static scm_sizet -fmalloc(ptr) - SCM ptr; -{ - if (SCM_MALLOCDATA (ptr)) - free (SCM_MALLOCDATA (ptr)); - return 0; -} - - -static int prinmalloc SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinmalloc (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts(scm_regular_string, "#<malloc ", port); - scm_intprint(SCM_CDR(exp), 16, port); - scm_gen_putc('>', port); - return 1; -} - - -int scm_tc16_malloc; -static scm_smobfuns mallocsmob = {scm_mark0, fmalloc, prinmalloc, 0}; - - - - -SCM -scm_malloc_obj (n) - scm_sizet n; -{ - SCM answer; - SCM mem; - - SCM_NEWCELL (answer); - SCM_DEFER_INTS; - mem = (n - ? (SCM)malloc (n) - : 0); - if (n && !mem) - { - SCM_ALLOW_INTS; - return SCM_BOOL_F; - } - SCM_SETCDR (answer, mem); - SCM_SETCAR (answer, scm_tc16_malloc); - SCM_ALLOW_INTS; - return answer; -} - - - - -void -scm_init_mallocs () -{ - scm_tc16_malloc = scm_newsmob (&mallocsmob); -} - diff --git a/libguile/mallocs.h b/libguile/mallocs.h deleted file mode 100644 index 19fa8e5cd..000000000 --- a/libguile/mallocs.h +++ /dev/null @@ -1,60 +0,0 @@ -/* classes: h_files */ - -#ifndef MALLOCSH -#define MALLOCSH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - -extern int scm_tc16_malloc; - -#define SCM_MALLOCP(X) (SCM_TYP16 (X) == scm_tc16_malloc) -#define SCM_MALLOCDATA(obj) ((char *)SCM_CDR(obj)) -#define SCM_SETMALLOCDATA(obj, val) ((char *)SCM_SETCDR(obj, val)) - - - -extern SCM scm_malloc_obj SCM_P ((scm_sizet n)); -extern void scm_init_mallocs SCM_P ((void)); - -#endif /* MALLOCSH */ diff --git a/libguile/markers.c b/libguile/markers.c deleted file mode 100644 index 2736b0df5..000000000 --- a/libguile/markers.c +++ /dev/null @@ -1,81 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "markers.h" - - -/* {GC marking} - */ - - -SCM -scm_mark0 (ptr) - SCM ptr; -{ - SCM_SETGC8MARK (ptr); - return SCM_BOOL_F; -} - - - -SCM -scm_markcdr (ptr) - SCM ptr; -{ - if (SCM_GC8MARKP (ptr)) - return SCM_BOOL_F; - SCM_SETGC8MARK (ptr); - return SCM_CDR (ptr); -} - - -scm_sizet -scm_free0 (ptr) - SCM ptr; -{ - return 0; -} - - diff --git a/libguile/markers.h b/libguile/markers.h deleted file mode 100644 index 6a80e61a2..000000000 --- a/libguile/markers.h +++ /dev/null @@ -1,59 +0,0 @@ -/* classes: h_files */ - -#ifndef MARKERSH -#define MARKERSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - - -extern SCM scm_mark0 SCM_P ((SCM ptr)); -extern SCM scm_markcdr SCM_P ((SCM ptr)); -extern scm_sizet scm_free0 SCM_P ((SCM ptr)); - -#endif /* MARKERSH */ diff --git a/libguile/mbstrings.c b/libguile/mbstrings.c deleted file mode 100644 index 41e04bf80..000000000 --- a/libguile/mbstrings.c +++ /dev/null @@ -1,505 +0,0 @@ - - -/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - -#include "extchrs.h" -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "unif.h" -#include "genio.h" -#include "read.h" - -#include "mbstrings.h" - - -SCM_PROC(s_multi_byte_string_p, "multi-byte-string?", 1, 0, 0, scm_multi_byte_string_p); - -SCM -scm_multi_byte_string_p (obj) - SCM obj; -{ - return (SCM_MB_STRINGP (obj) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - -SCM -scm_regular_string_p (obj) - SCM obj; -{ - return (SCM_REGULAR_STRINGP (obj) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - -SCM_PROC(s_list_to_multi_byte_string, "list->multi-byte-string", 1, 0, 0, scm_multi_byte_string); -SCM_PROC(s_multi_byte_string, "multi-byte-string", 0, 0, 1, scm_multi_byte_string); - -SCM -scm_multi_byte_string (chrs) - SCM chrs; -{ - SCM res; - register char *data; - long i; - long byte_len; - - i = scm_ilength (chrs); - SCM_ASSERT (i >= 0, chrs, SCM_ARG1, s_multi_byte_string); - i = i * XMB_CUR_MAX; - res = scm_makstr (i, 0); - SCM_SETLENGTH (res, SCM_LENGTH (res), scm_tc7_mb_string); - data = SCM_CHARS (res); - byte_len = 0; - xwctomb (0, 0); - while (i && SCM_NNULLP (chrs)) - { - int used; - SCM ch; - - ch = SCM_CAR (chrs); - SCM_ASSERT (SCM_ICHRP (ch), chrs, SCM_ARG1, s_multi_byte_string); - used = xwctomb (data + byte_len, SCM_ICHR (ch)); - SCM_ASSERT (used >= 0, chrs, SCM_ARG1, s_multi_byte_string); - byte_len += (used ? used : 1); - chrs = SCM_CDR (chrs); - --i; - } - res = scm_vector_set_length_x (res, SCM_MAKINUM (byte_len)); - return res; -} - - -int -scm_mb_ilength (data, size) - unsigned char * data; - int size; -{ - int pos; - int len; - - len = 0; - pos = 0; - xmblen (0, 0); - while (pos < size) - { - int inc; - - inc = xmblen (data + pos, size - pos); - if (inc == 0) - ++inc; - - if (inc < 0) - return -1; - - ++len; - pos += inc; - } - - return len; -} - -SCM_PROC(s_multi_byte_string_length, "multi-byte-string-length", 1, 0, 0, scm_multi_byte_string_length); - -SCM -scm_multi_byte_string_length (str) - SCM str; -{ - int size; - int len; - unsigned char * data; - - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_multi_byte_string_length); - - data = SCM_ROCHARS (str); - size = SCM_ROLENGTH (str); - len = scm_mb_ilength (data, size); - SCM_ASSERT (len >= 0, str, SCM_ARG1, s_multi_byte_string_length); - return SCM_MAKINUM (len); -} - - -SCM_PROC(s_symbol_multi_byte_p, "symbol-multi-byte?", 1, 0, 0, scm_symbol_multi_byte_p); - -SCM -scm_symbol_multi_byte_p (symbol) - SCM symbol; -{ - return SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol); -} - -SCM_PROC(s_set_symbol_multi_byte_x, "set-symbol-multi-byte!", 2, 0, 0, scm_set_symbol_multi_byte_x); - -SCM -scm_set_symbol_multi_byte_x (symbol, val) - SCM symbol; - SCM val; -{ - if (SCM_TYP7 (symbol) == scm_tc7_msymbol) - { - SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol) = (SCM_FALSEP (val) - ? SCM_BOOL_F - : SCM_BOOL_T); - } - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_regular_port_p, "regular-port?", 1, 0, 0, scm_regular_port_p); - -SCM -scm_regular_port_p (p) - SCM p; -{ - return (SCM_PORT_REPRESENTATION(p) == scm_regular_port - ? SCM_BOOL_T - : SCM_BOOL_F); -} - -SCM_PROC(s_regular_port_x, "regular-port!", 1, 0, 0, scm_regular_port_x); - -SCM -scm_regular_port_x (p) - SCM p; -{ - SCM_PORT_REPRESENTATION(p) = scm_regular_port; - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_multi_byte_port_p, "multi-byte-port?", 1, 0, 0, scm_multi_byte_port_p); - -SCM -scm_multi_byte_port_p (p) - SCM p; -{ - return (SCM_PORT_REPRESENTATION(p) == scm_mb_port - ? SCM_BOOL_T - : SCM_BOOL_F); -} - -SCM_PROC(s_multi_byte_port_x, "multi-byte-port!", 1, 0, 0, scm_multi_byte_port_x); - -SCM -scm_multi_byte_port_x (p) - SCM p; -{ - SCM_PORT_REPRESENTATION(p) = scm_mb_port; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_wide_character_port_p, "wide-character-port?", 1, 0, 0, scm_wide_character_port_p); - -SCM -scm_wide_character_port_p (p) - SCM p; -{ - return (SCM_PORT_REPRESENTATION(p) == scm_wchar_port - ? SCM_BOOL_T - : SCM_BOOL_F); -} - -SCM_PROC(s_wide_character_port_x, "wide-character-port!", 1, 0, 0, scm_wide_character_port_x); - -SCM -scm_wide_character_port_x (p) - SCM p; -{ - SCM_PORT_REPRESENTATION(p) = scm_wchar_port; - return SCM_UNSPECIFIED; -} - - - - - - -void -scm_put_wchar (c, port, writing) - int c; - SCM port; - int writing; -{ - if (writing) - scm_gen_puts (scm_regular_string, "#\\", port); - switch (SCM_PORT_REPRESENTATION (port)) - { - case scm_regular_port: - { - if (c < 256) - { - if (!writing) - scm_gen_putc ((unsigned char)c, port); - else if ((c <= ' ') && scm_charnames[c]) - scm_gen_puts (scm_regular_string, scm_charnames[c], port); - else if (c > '\177') - scm_intprint (c, 8, port); - else - scm_gen_putc ((int) c, port); - } - else - { - print_octal: - if (!writing) - scm_gen_putc ('\\', port); - scm_intprint (c, 8, port); - } - break; - } - - case scm_mb_port: - { - char buf[256]; - int len; - - if (XMB_CUR_MAX > sizeof (buf)) - goto print_octal; - - len = xwctomb (buf, c); - - if (len < 0) - goto print_octal; - - if (len == 0) - scm_gen_putc (0, port); - else - scm_gen_putc (c, port); - break; - } - - case scm_wchar_port: - { - scm_gen_putc (c, port); - break; - } - } -} - - - - - - -void -scm_print_mb_string (exp, port, writing) - SCM exp; - SCM port; - int writing; -{ - if (writing) - { - int i; - int len; - char * data; - - scm_gen_putc ('\"', port); - i = 0; - len = SCM_ROLENGTH (exp); - data = SCM_ROCHARS (exp); - - while (i < len) - { - xwchar_t c; - int inc; - - inc = xmbtowc (&c, data + i, len - i); - if (inc == 0) - inc = 1; - if (inc < 0) - { - inc = 1; - c = data[i]; - } - i += inc; - switch (c) - { - case '\"': - case '\\': - scm_gen_putc ('\\', port); - default: - scm_gen_putc (c, port); - } - } - scm_gen_putc ('\"', port); - } - else - scm_gen_write (scm_mb_string, SCM_ROCHARS (exp), SCM_ROLENGTH (exp), port); -} - - - -void -scm_print_mb_symbol (exp, port) - SCM exp; - SCM port; -{ - int pos; - int end; - int len; - char * str; - int weird; - int maybe_weird; - int mw_pos = 0; /* initialized to placate compiler */ - int inc = 0; /* same */ - xwchar_t c; - - len = SCM_LENGTH (exp); - str = SCM_CHARS (exp); - scm_remember (&exp); - pos = 0; - weird = 0; - maybe_weird = 0; - - for (end = pos; end < len; end += inc) - { - inc = xmbtowc (&c, str + end, len - end); - if (inc < 0) - { - inc = 1; - c = str[end]; - goto weird_handler; - } - if (inc == 0) - { - inc = 1; - goto weird_handler; - } - switch (c) - { -#ifdef BRACKETS_AS_PARENS - case '[': - case ']': -#endif - case '(': - case ')': - case '\"': - case ';': - case SCM_WHITE_SPACES: - case SCM_LINE_INCREMENTORS: - weird_handler: - if (maybe_weird) - { - end = mw_pos; - maybe_weird = 0; - } - if (!weird) - { - scm_gen_write (scm_regular_string, "#{", 2, port); - weird = 1; - } - if (pos < end) - { - int q; - int qinc; - - q = pos; - while (q < end) - { - qinc = xmbtowc (&c, str + q, end - q); - if (inc <= 0) - { - inc = 1; - c = str[q]; - } - scm_gen_putc (c, port); - q += qinc; - } - } - { - char buf[2]; - buf[0] = '\\'; - buf[1] = str[end]; - scm_gen_write (scm_regular_string, buf, 2, port); - } - pos = end + 1; - break; - case '\\': - if (weird) - goto weird_handler; - if (!maybe_weird) - { - maybe_weird = 1; - mw_pos = pos; - } - break; - case '}': - case '#': - if (weird) - goto weird_handler; - break; - default: - break; - } - } - if (pos < end) - { - int q; - int qinc; - q = pos; - while (q < end) - { - qinc = xmbtowc (&c, str + q, end - q); - if (inc <= 0) - inc = 1; - scm_gen_putc (c, port); - q += qinc; - } - } - if (weird) - scm_gen_write (scm_regular_string, "}#", 2, port); -} - - - - - -void -scm_init_mbstrings () -{ -#include "mbstrings.x" -} - diff --git a/libguile/mbstrings.h b/libguile/mbstrings.h deleted file mode 100644 index 84482c5a8..000000000 --- a/libguile/mbstrings.h +++ /dev/null @@ -1,78 +0,0 @@ -/* classes: h_files */ - -#ifndef MBSTRINGSH -#define MBSTRINGSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" -#include "libguile/symbols.h" - - -#define SCM_MB_STRINGP(x) ( (SCM_TYP7(x)==scm_tc7_mb_string) \ - || ( (SCM_TYP7(x) == scm_tc7_msymbol) \ - && (SCM_SYMBOL_MULTI_BYTE_STRINGP (x) != SCM_BOOL_F))) -#define SCM_REGULAR_STRINGP(x) (SCM_TYP7D(x)==scm_tc7_string) - - - - - -extern SCM scm_multi_byte_string_p SCM_P ((SCM obj)); -extern SCM scm_regular_string_p SCM_P ((SCM obj)); -extern SCM scm_multi_byte_string SCM_P ((SCM chrs)); -extern int scm_mb_ilength SCM_P ((unsigned char * data, int size)); -extern SCM scm_multi_byte_string_length SCM_P ((SCM str)); -extern SCM scm_symbol_multi_byte_p SCM_P ((SCM symbol)); -extern SCM scm_set_symbol_multi_byte_x SCM_P ((SCM symbol, SCM val)); -extern SCM scm_regular_port_p SCM_P ((SCM p)); -extern SCM scm_regular_port_x SCM_P ((SCM p)); -extern SCM scm_multi_byte_port_p SCM_P ((SCM p)); -extern SCM scm_multi_byte_port_x SCM_P ((SCM p)); -extern SCM scm_wide_character_port_p SCM_P ((SCM p)); -extern SCM scm_wide_character_port_x SCM_P ((SCM p)); -extern void scm_put_wchar SCM_P ((int c, SCM port, int writing)); -extern void scm_print_mb_string SCM_P ((SCM exp, SCM port, int writing)); -extern void scm_print_mb_symbol SCM_P ((SCM exp, SCM port)); -extern void scm_init_mbstrings SCM_P ((void)); - -#endif /* MBSTRINGSH */ diff --git a/libguile/numbers.c b/libguile/numbers.c deleted file mode 100644 index 360527611..000000000 --- a/libguile/numbers.c +++ /dev/null @@ -1,3704 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include <math.h> -#include "_scm.h" -#include "genio.h" -#include "unif.h" - -#include "numbers.h" - -#define DIGITS '0':case '1':case '2':case '3':case '4':\ - case '5':case '6':case '7':case '8':case '9' - - -/* IS_INF tests its floating point number for infiniteness - */ -#ifndef IS_INF -# define IS_INF(x) ((x)==(x)/2) -#endif - -/* MAXEXP is the maximum double precision expontent - * FLTMAX is less than or scm_equal the largest single precision float - */ - -#ifdef SCM_FLOATS -# ifdef STDC_HEADERS -# ifndef GO32 -# include <float.h> -# endif /* ndef GO32 */ -# endif /* def STDC_HEADERS */ -# ifdef DBL_MAX_10_EXP -# define MAXEXP DBL_MAX_10_EXP -# else -# define MAXEXP 308 /* IEEE doubles */ -# endif /* def DBL_MAX_10_EXP */ -# ifdef FLT_MAX -# define FLTMAX FLT_MAX -# else -# define FLTMAX 1e+23 -# endif /* def FLT_MAX */ -#endif /* def SCM_FLOATS */ - - - -SCM_PROC(s_exact_p, "exact?", 1, 0, 0, scm_exact_p); - -SCM -scm_exact_p(x) - SCM x; -{ - if SCM_INUMP(x) return SCM_BOOL_T; -#ifdef SCM_BIGDIG - if (SCM_NIMP(x) && SCM_BIGP(x)) return SCM_BOOL_T; -#endif - return SCM_BOOL_F; -} - -SCM_PROC(s_odd_p, "odd?", 1, 0, 0, scm_odd_p); - -SCM -scm_odd_p(n) - SCM n; -{ -#ifdef SCM_BIGDIG - if SCM_NINUMP(n) { - SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_odd_p); - return (1 & SCM_BDIGITS(n)[0]) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_odd_p); -#endif - return (4 & (int)n) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_even_p, "even?", 1, 0, 0, scm_even_p); - -SCM -scm_even_p(n) - SCM n; -{ -#ifdef SCM_BIGDIG - if SCM_NINUMP(n) { - SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_even_p); - return (1 & SCM_BDIGITS(n)[0]) ? SCM_BOOL_F : SCM_BOOL_T; - } -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_even_p); -#endif - return (4 & (int)n) ? SCM_BOOL_F : SCM_BOOL_T; -} - -SCM_PROC(s_abs, "abs", 1, 0, 0, scm_abs); - -SCM -scm_abs(x) - SCM x; -{ -#ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_abs); - if (SCM_TYP16(x)==scm_tc16_bigpos) return x; - return scm_copybig(x, 0); - } -#else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_abs); -#endif - if (SCM_INUM(x) >= 0) return x; - x = -SCM_INUM(x); - if (!SCM_POSFIXABLE(x)) -#ifdef SCM_BIGDIG - return scm_long2big(x); -#else - scm_num_overflow (s_abs); -#endif - return SCM_MAKINUM(x); -} - -SCM_PROC(s_quotient, "quotient", 2, 0, 0, scm_quotient); - -SCM -scm_quotient(x, y) - SCM x; - SCM y; -{ - register long z; -#ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - long w; - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_quotient); - if SCM_NINUMP(y) { - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return scm_divbigbig(SCM_BDIGITS(x), - SCM_NUMDIGS(x), - SCM_BDIGITS(y), - SCM_NUMDIGS(y), - SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), - 2); - } - z = SCM_INUM(y); - SCM_ASRTGO(z, ov); - if (1==z) return x; - if (z < 0) z = -z; - if (z < SCM_BIGRAD) { - w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0)); - scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z); - return scm_normbig(w); - } -#ifndef SCM_DIGSTOOBIG - w = scm_pseudolong(z); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&w, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 2); -#else - { SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(z, zdigs); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 2); - } -#endif - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_quotient); -# endif - return SCM_INUM0; - } -#else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_quotient); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_quotient); -#endif - if ((z = SCM_INUM(y))==0) - ov: scm_num_overflow (s_quotient); - z = SCM_INUM(x)/z; -#ifdef BADIVSGNS - { -#if (__TURBOC__==1) - long t = ((y<0) ? -SCM_INUM(x) : SCM_INUM(x))%SCM_INUM(y); -#else - long t = SCM_INUM(x)%SCM_INUM(y); -#endif - if (t==0) ; - else if (t < 0) - if (x < 0) ; - else z--; - else if (x < 0) z++; - } -#endif - if (!SCM_FIXABLE(z)) -#ifdef SCM_BIGDIG - return scm_long2big(z); -#else - scm_num_overflow (s_quotient); -#endif - return SCM_MAKINUM(z); -} - -SCM_PROC(s_remainder, "remainder", 2, 0, 0, scm_remainder); - -SCM -scm_remainder(x, y) - SCM x; - SCM y; -{ - register long z; -#ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_remainder); - if SCM_NINUMP(y) { - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(x), 0); - } - if (!(z = SCM_INUM(y))) goto ov; - return scm_divbigint(x, z, SCM_BIGSIGN(x), 0); - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_remainder); -# endif - return x; - } -#else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_remainder); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_remainder); -#endif - if (!(z = SCM_INUM(y))) - ov: scm_num_overflow (s_remainder); -#if (__TURBOC__==1) - if (z < 0) z = -z; -#endif - z = SCM_INUM(x)%z; -#ifdef BADIVSGNS - if (!z) ; - else if (z < 0) - if (x < 0) ; - else z += SCM_INUM(y); - else if (x < 0) z -= SCM_INUM(y); -#endif - return SCM_MAKINUM(z); -} - -SCM_PROC(s_modulo, "modulo", 2, 0, 0, scm_modulo); - -SCM -scm_modulo(x, y) - SCM x; - SCM y; -{ - register long yy, z; -#ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_modulo); - if SCM_NINUMP(y) { - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(y), (SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y)) ? 1 : 0); - } - if (!(z = SCM_INUM(y))) goto ov; - return scm_divbigint(x, z, y < 0, (SCM_BIGSIGN(x) ? (y > 0) : (y < 0)) ? 1 : 0); - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_modulo); -# endif - return (SCM_BIGSIGN(y) ? (x>0) : (x<0)) ? scm_sum(x, y) : x; - } -#else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_modulo); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_modulo); -#endif - if (!(yy = SCM_INUM(y))) - ov: scm_num_overflow (s_modulo); -#if (__TURBOC__==1) - z = SCM_INUM(x); - z = ((yy<0) ? -z : z)%yy; -#else - z = SCM_INUM(x)%yy; -#endif - return SCM_MAKINUM(((yy<0) ? (z>0) : (z<0)) ? z+yy : z); -} - -SCM_PROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd); - -SCM -scm_gcd(x, y) - SCM x; - SCM y; -{ - register long u, v, k, t; - if SCM_UNBNDP(y) return SCM_UNBNDP(x) ? SCM_INUM0 : x; - tailrec: -#ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - big_gcd: - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_gcd); - if SCM_BIGSIGN(x) x = scm_copybig(x, 0); - newy: - if SCM_NINUMP(y) { - SCM_ASSERT(SCM_NIMP(y) && SCM_BIGP(y), y, SCM_ARG2, s_gcd); - if SCM_BIGSIGN(y) y = scm_copybig(y, 0); - switch (scm_bigcomp(x, y)) { - case -1: - swaprec: t = scm_remainder(x, y); x = y; y = t; goto tailrec; - case 0: return x; - case 1: y = scm_remainder(y, x); goto newy; - } - /* instead of the switch, we could just return scm_gcd(y, scm_modulo(x, y)); */ - } - if (SCM_INUM0==y) return x; goto swaprec; - } - if SCM_NINUMP(y) { t=x; x=y; y=t; goto big_gcd;} -#else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_gcd); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_gcd); -#endif - u = SCM_INUM(x); - if (u<0) u = -u; - v = SCM_INUM(y); - if (v<0) v = -v; - else if (0==v) goto getout; - if (0==u) {u = v; goto getout;} - for (k = 1;!(1 & ((int)u|(int)v));k <<= 1, u >>= 1, v >>= 1); - if (1 & (int)u) t = -v; - else { - t = u; - b3: - t = SCM_SRS(t, 1); - } - if (!(1 & (int)t)) goto b3; - if (t>0) u = t; - else v = -t; - if ((t = u-v)) goto b3; - u = u*k; - getout: - if (!SCM_POSFIXABLE(u)) -#ifdef SCM_BIGDIG - return scm_long2big(u); -#else - scm_num_overflow (s_gcd); -#endif - return SCM_MAKINUM(u); -} - -SCM_PROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm); - -SCM -scm_lcm(n1, n2) - SCM n1; - SCM n2; -{ - SCM d; - if SCM_UNBNDP(n2) { - n2 = SCM_MAKINUM(1L); - if SCM_UNBNDP(n1) return n2; - } - d = scm_gcd(n1, n2); - if (SCM_INUM0==d) return d; - return scm_abs(scm_product(n1, scm_quotient(n2, d))); -} - -#ifndef SCM_BIGDIG -# ifndef SCM_FLOATS -# define scm_long2num SCM_MAKINUM -# endif -#endif - -#ifndef scm_long2num -SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand); - -SCM -scm_logand(n1, n2) - SCM n1; - SCM n2; -{ - return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logand) - & scm_num2long(n2, (char *)SCM_ARG2, s_logand)); -} - -SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior); - -SCM -scm_logior(n1, n2) - SCM n1; - SCM n2; -{ - return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logior) - | scm_num2long(n2, (char *)SCM_ARG2, s_logior)); -} - -SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor); - -SCM -scm_logxor(n1, n2) - SCM n1; - SCM n2; -{ - return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logxor) - ^ scm_num2long(n2, (char *)SCM_ARG2, s_logxor)); -} - -SCM_PROC(s_logtest, "logtest", 2, 0, 0, scm_logtest); - -SCM -scm_logtest(n1, n2) - SCM n1; - SCM n2; -{ - return ((scm_num2long (n1, (char *)SCM_ARG1, s_logtest) - & scm_num2long (n2, (char *)SCM_ARG2, s_logtest)) - ? SCM_BOOL_T : SCM_BOOL_F); -} - - -SCM_PROC(s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p); - -SCM -scm_logbit_p(n1, n2) - SCM n1; - SCM n2; -{ - return (((1 << scm_num2long (n1, (char *)SCM_ARG1, s_logtest)) - & scm_num2long (n2, (char *)SCM_ARG2, s_logtest)) - ? SCM_BOOL_T : SCM_BOOL_F); -} - -#else - -SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand); - -SCM -scm_logand(n1, n2) - SCM n1; - SCM n2; -{ - SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logand); - SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logand); - return SCM_MAKINUM(SCM_INUM(n1) & SCM_INUM(n2)); -} - -SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior); - -SCM -scm_logior(n1, n2) - SCM n1; - SCM n2; -{ - SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logior); - SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logior); - return SCM_MAKINUM(SCM_INUM(n1) | SCM_INUM(n2)); -} - -SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor); - -SCM -scm_logxor(n1, n2) - SCM n1; - SCM n2; -{ - SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logxor); - SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logxor); - return SCM_MAKINUM(SCM_INUM(n1) ^ SCM_INUM(n2)); -} - -SCM_PROC(s_logtest, "logtest", 2, 0, 0, scm_logtest); - -SCM -scm_logtest(n1, n2) - SCM n1; - SCM n2; -{ - SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logtest); - SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logtest); - return (SCM_INUM(n1) & SCM_INUM(n2)) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p); - -SCM -scm_logbit_p(n1, n2) - SCM n1; - SCM n2; -{ - SCM_ASSERT(SCM_INUMP(n1) && SCM_INUM(n1) >= 0, n1, SCM_ARG1, s_logbit_p); - SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logbit_p); - return ((1 << SCM_INUM(n1)) & SCM_INUM(n2)) ? SCM_BOOL_T : SCM_BOOL_F; -} -#endif - -SCM_PROC(s_lognot, "lognot", 1, 0, 0, scm_lognot); - -SCM -scm_lognot(n) - SCM n; -{ - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_lognot); - return scm_difference(SCM_MAKINUM(-1L), n); -} - -SCM_PROC(s_integer_expt, "integer-expt", 2, 0, 0, scm_integer_expt); - -SCM -scm_integer_expt(z1, z2) - SCM z1; - SCM z2; -{ - SCM acc = SCM_MAKINUM(1L); -#ifdef SCM_BIGDIG - if (SCM_INUM0==z1 || acc==z1) return z1; - else if (SCM_MAKINUM(-1L)==z1) return SCM_BOOL_F==scm_even_p(z2)?z1:acc; -#endif - SCM_ASSERT(SCM_INUMP(z2), z2, SCM_ARG2, s_integer_expt); - z2 = SCM_INUM(z2); - if (z2 < 0) { - z2 = -z2; - z1 = scm_divide(z1, SCM_UNDEFINED); - } - while(1) { - if (0==z2) return acc; - if (1==z2) return scm_product(acc, z1); - if (z2 & 1) acc = scm_product(acc, z1); - z1 = scm_product(z1, z1); - z2 >>= 1; - } -} - -SCM_PROC(s_ash, "ash", 2, 0, 0, scm_ash); - -SCM -scm_ash(n, cnt) - SCM n; - SCM cnt; -{ - SCM res = SCM_INUM(n); - SCM_ASSERT(SCM_INUMP(cnt), cnt, SCM_ARG2, s_ash); -#ifdef SCM_BIGDIG - if(cnt < 0) { - res = scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(-SCM_INUM(cnt))); - if (SCM_NFALSEP(scm_negative_p(n))) - return scm_sum(SCM_MAKINUM(-1L), scm_quotient(scm_sum(SCM_MAKINUM(1L), n), res)); - else return scm_quotient(n, res); - } - else return scm_product(n, scm_integer_expt(SCM_MAKINUM(2), cnt)); -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_ash); - cnt = SCM_INUM(cnt); - if (cnt < 0) return SCM_MAKINUM(SCM_SRS(res, -cnt)); - res = SCM_MAKINUM(res<<cnt); - if (SCM_INUM(res)>>cnt != SCM_INUM(n)) - scm_num_overflow (s_ash); - return res; -#endif -} - -SCM_PROC(s_bit_extract, "bit-extract", 3, 0, 0, scm_bit_extract); - -SCM -scm_bit_extract(n, start, end) - SCM n; - SCM start; - SCM end; -{ - SCM_ASSERT(SCM_INUMP(start), start, SCM_ARG2, s_bit_extract); - SCM_ASSERT(SCM_INUMP(end), end, SCM_ARG3, s_bit_extract); - start = SCM_INUM(start); end = SCM_INUM(end); - SCM_ASSERT(end >= start, SCM_MAKINUM(end), SCM_OUTOFRANGE, s_bit_extract); -#ifdef SCM_BIGDIG - if SCM_NINUMP(n) - return - scm_logand(scm_difference(scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(end - start)), - SCM_MAKINUM(1L)), - scm_ash(n, SCM_MAKINUM(-start))); -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_bit_extract); -#endif - return SCM_MAKINUM((SCM_INUM(n)>>start) & ((1L<<(end-start))-1)); -} - -char scm_logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; -SCM_PROC(s_logcount, "logcount", 1, 0, 0, scm_logcount); - -SCM -scm_logcount(n) - SCM n; -{ - register unsigned long c = 0; - register long nn; -#ifdef SCM_BIGDIG - if SCM_NINUMP(n) { - scm_sizet i; SCM_BIGDIG *ds, d; - SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_logcount); - if SCM_BIGSIGN(n) return scm_logcount(scm_difference(SCM_MAKINUM(-1L), n)); - ds = SCM_BDIGITS(n); - for(i = SCM_NUMDIGS(n); i--; ) - for(d = ds[i]; d; d >>= 4) c += scm_logtab[15 & d]; - return SCM_MAKINUM(c); - } -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_logcount); -#endif - if ((nn = SCM_INUM(n)) < 0) nn = -1 - nn; - for(; nn; nn >>= 4) c += scm_logtab[15 & nn]; - return SCM_MAKINUM(c); -} - -char scm_ilentab[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4}; -SCM_PROC(s_integer_length, "integer-length", 1, 0, 0, scm_integer_length); - -SCM -scm_integer_length(n) - SCM n; -{ - register unsigned long c = 0; - register long nn; - unsigned int l = 4; -#ifdef SCM_BIGDIG - if SCM_NINUMP(n) { - SCM_BIGDIG *ds, d; - SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_integer_length); - if SCM_BIGSIGN(n) return scm_integer_length(scm_difference(SCM_MAKINUM(-1L), n)); - ds = SCM_BDIGITS(n); - d = ds[c = SCM_NUMDIGS(n)-1]; - for(c *= SCM_BITSPERDIG; d; d >>= 4) {c += 4; l = scm_ilentab[15 & d];} - return SCM_MAKINUM(c - 4 + l); - } -#else - SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_integer_length); -#endif - if ((nn = SCM_INUM(n)) < 0) nn = -1 - nn; - for(;nn; nn >>= 4) {c += 4; l = scm_ilentab[15 & nn];} - return SCM_MAKINUM(c - 4 + l); -} - - -#ifdef SCM_BIGDIG -char s_bignum[] = "bignum"; - -SCM -scm_mkbig(nlen, sign) - scm_sizet nlen; - int sign; -{ - SCM v = nlen; - if (((v << 16) >> 16) != nlen) - scm_wta(SCM_MAKINUM(nlen), (char *)SCM_NALLOC, s_bignum); - SCM_NEWCELL(v); - SCM_DEFER_INTS; - SCM_SETCHARS(v, scm_must_malloc((long)(nlen*sizeof(SCM_BIGDIG)), s_bignum)); - SCM_SETNUMDIGS(v, nlen, sign?scm_tc16_bigneg:scm_tc16_bigpos); - SCM_ALLOW_INTS; - return v; -} - - -SCM -scm_big2inum(b, l) - SCM b; - scm_sizet l; -{ - unsigned long num = 0; - SCM_BIGDIG *tmp = SCM_BDIGITS(b); - while (l--) num = SCM_BIGUP(num) + tmp[l]; - if (SCM_TYP16(b)==scm_tc16_bigpos) { - if SCM_POSFIXABLE(num) return SCM_MAKINUM(num); - } - else if SCM_UNEGFIXABLE(num) return SCM_MAKINUM(-num); - return b; -} - - -char s_adjbig[] = "scm_adjbig"; - -SCM -scm_adjbig(b, nlen) - SCM b; - scm_sizet nlen; -{ - long nsiz = nlen; - if (((nsiz << 16) >> 16) != nlen) scm_wta(SCM_MAKINUM(nsiz), (char *)SCM_NALLOC, s_adjbig); - SCM_DEFER_INTS; - SCM_SETCHARS(b, (SCM_BIGDIG *)scm_must_realloc((char *)SCM_CHARS(b), - (long)(SCM_NUMDIGS(b)*sizeof(SCM_BIGDIG)), - (long)(nsiz*sizeof(SCM_BIGDIG)), s_adjbig)); - SCM_SETNUMDIGS(b, nsiz, SCM_TYP16(b)); - SCM_ALLOW_INTS; - return b; -} - - - -SCM -scm_normbig(b) - SCM b; -{ -#ifndef _UNICOS - scm_sizet nlen = SCM_NUMDIGS(b); -#else - int nlen = SCM_NUMDIGS(b); /* unsigned nlen breaks on Cray when nlen => 0 */ -#endif - SCM_BIGDIG *zds = SCM_BDIGITS(b); - while (nlen-- && !zds[nlen]); nlen++; - if (nlen * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM)) - if SCM_INUMP(b = scm_big2inum(b, (scm_sizet)nlen)) return b; - if (SCM_NUMDIGS(b)==nlen) return b; - return scm_adjbig(b, (scm_sizet)nlen); -} - - - -SCM -scm_copybig(b, sign) - SCM b; - int sign; -{ - scm_sizet i = SCM_NUMDIGS(b); - SCM ans = scm_mkbig(i, sign); - SCM_BIGDIG *src = SCM_BDIGITS(b), *dst = SCM_BDIGITS(ans); - while (i--) dst[i] = src[i]; - return ans; -} - - - -SCM -scm_long2big(n) - long n; -{ - scm_sizet i = 0; - SCM_BIGDIG *digits; - SCM ans = scm_mkbig(SCM_DIGSPERLONG, n<0); - digits = SCM_BDIGITS(ans); - if (n < 0) n = -n; - while (i < SCM_DIGSPERLONG) { - digits[i++] = SCM_BIGLO(n); - n = SCM_BIGDN((unsigned long)n); - } - return ans; -} - -#ifdef LONGLONGS - -SCM -scm_long_long2big(n) - long_long n; -{ - scm_sizet i; - SCM_BIGDIG *digits; - SCM ans; - int n_digits; - - { - long tn; - tn = (long) n; - if ((long long)tn == n) - return scm_long2big (tn); - } - - { - long_long tn; - - for (tn = n, n_digits = 0; - tn; - ++n_digits, tn = SCM_BIGDN ((ulong_long)tn)) - ; - } - - i = 0; - ans = scm_mkbig(n_digits, n<0); - digits = SCM_BDIGITS(ans); - if (n < 0) - n = -n; - while (i < n_digits) { - digits[i++] = SCM_BIGLO(n); - n = SCM_BIGDN((ulong_long)n); - } - return ans; -} -#endif - - -SCM -scm_2ulong2big(np) - unsigned long * np; -{ - unsigned long n; - scm_sizet i; - SCM_BIGDIG *digits; - SCM ans; - - ans = scm_mkbig(2 * SCM_DIGSPERLONG, 0); - digits = SCM_BDIGITS(ans); - - n = np[0]; - for (i = 0; i < SCM_DIGSPERLONG; ++i) - { - digits[i] = SCM_BIGLO(n); - n = SCM_BIGDN((unsigned long)n); - } - n = np[1]; - for (i = 0; i < SCM_DIGSPERLONG; ++i) - { - digits[i + SCM_DIGSPERLONG] = SCM_BIGLO(n); - n = SCM_BIGDN((unsigned long)n); - } - return ans; -} - - - -SCM -scm_ulong2big(n) - unsigned long n; -{ - scm_sizet i = 0; - SCM_BIGDIG *digits; - SCM ans = scm_mkbig(SCM_DIGSPERLONG, 0); - digits = SCM_BDIGITS(ans); - while (i < SCM_DIGSPERLONG) { - digits[i++] = SCM_BIGLO(n); - n = SCM_BIGDN(n); - } - return ans; -} - - - -int -scm_bigcomp(x, y) - SCM x; - SCM y; -{ - int xsign = SCM_BIGSIGN(x); - int ysign = SCM_BIGSIGN(y); - scm_sizet xlen, ylen; - if (ysign < xsign) return 1; - if (ysign > xsign) return -1; - if ((ylen = SCM_NUMDIGS(y)) > (xlen = SCM_NUMDIGS(x))) return (xsign) ? -1 : 1; - if (ylen < xlen) return (xsign) ? 1 : -1; - while(xlen-- && (SCM_BDIGITS(y)[xlen]==SCM_BDIGITS(x)[xlen])); - if (-1==xlen) return 0; - return (SCM_BDIGITS(y)[xlen] > SCM_BDIGITS(x)[xlen]) ? - (xsign ? -1 : 1) : (xsign ? 1 : -1); -} - -#ifndef SCM_DIGSTOOBIG - - -long -scm_pseudolong(x) - long x; -{ - union { - long l; - SCM_BIGDIG bd[SCM_DIGSPERLONG]; - } p; - scm_sizet i = 0; - if (x < 0) x = -x; - while (i < SCM_DIGSPERLONG) {p.bd[i++] = SCM_BIGLO(x); x = SCM_BIGDN(x);} - /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */ - return p.l; -} - -#else - - -void -scm_longdigs(x, digs) - long x; - SCM_BIGDIG digs[]; -{ - scm_sizet i = 0; - if (x < 0) x = -x; - while (i < SCM_DIGSPERLONG) {digs[i++] = SCM_BIGLO(x); x = SCM_BIGDN(x);} -} -#endif - - - -SCM -scm_addbig(x, nx, xsgn, bigy, sgny) - SCM_BIGDIG *x; - scm_sizet nx; - int xsgn; - SCM bigy; - int sgny; -{ - /* Assumes nx <= SCM_NUMDIGS(bigy) */ - /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */ - long num = 0; - scm_sizet i = 0, ny = SCM_NUMDIGS(bigy); - SCM z = scm_copybig(bigy, SCM_BIGSIGN(bigy) ^ sgny); - SCM_BIGDIG *zds = SCM_BDIGITS(z); - if (xsgn ^ SCM_BIGSIGN(z)) { - do { - num += (long) zds[i] - x[i]; - if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;} - else {zds[i] = SCM_BIGLO(num); num = 0;} - } while (++i < nx); - if (num && nx==ny) { - num = 1; i = 0; - SCM_SETCAR (z, SCM_CAR (z) ^ 0x0100); - do { - num += (SCM_BIGRAD-1) - zds[i]; - zds[i++] = SCM_BIGLO(num); - num = SCM_BIGDN(num); - } while (i < ny); - } - else while (i < ny) { - num += zds[i]; - if (num < 0) {zds[i++] = num + SCM_BIGRAD; num = -1;} - else {zds[i++] = SCM_BIGLO(num); num = 0;} - } - } else { - do { - num += (long) zds[i] + x[i]; - zds[i++] = SCM_BIGLO(num); - num = SCM_BIGDN(num); - } while (i < nx); - if (!num) return z; - while (i < ny) { - num += zds[i]; - zds[i++] = SCM_BIGLO(num); - num = SCM_BIGDN(num); - if (!num) return z; - } - if (num) {z = scm_adjbig(z, ny+1); SCM_BDIGITS(z)[ny] = num; return z;} - } - return scm_normbig(z); -} - - -SCM -scm_mulbig(x, nx, y, ny, sgn) - SCM_BIGDIG *x; - scm_sizet nx; - SCM_BIGDIG *y; - scm_sizet ny; - int sgn; -{ - scm_sizet i = 0, j = nx + ny; - unsigned long n = 0; - SCM z = scm_mkbig(j, sgn); - SCM_BIGDIG *zds = SCM_BDIGITS(z); - while (j--) zds[j] = 0; - do { - j = 0; - if (x[i]) { - do { - n += zds[i + j] + ((unsigned long) x[i] * y[j]); - zds[i + j++] = SCM_BIGLO(n); - n = SCM_BIGDN(n); - } while (j < ny); - if (n) {zds[i + j] = n; n = 0;} - } - } while (++i < nx); - return scm_normbig(z); -} - - -unsigned int -scm_divbigdig(ds, h, div) - SCM_BIGDIG *ds; - scm_sizet h; - SCM_BIGDIG div; -{ - register unsigned long t2 = 0; - while(h--) { - t2 = SCM_BIGUP(t2) + ds[h]; - ds[h] = t2 / div; - t2 %= div; - } - return t2; -} - - - -SCM -scm_divbigint(x, z, sgn, mode) - SCM x; - long z; - int sgn; - int mode; -{ - if (z < 0) z = -z; - if (z < SCM_BIGRAD) { - register unsigned long t2 = 0; - register SCM_BIGDIG *ds = SCM_BDIGITS(x); - scm_sizet nd = SCM_NUMDIGS(x); - while(nd--) t2 = (SCM_BIGUP(t2) + ds[nd]) % z; - if (mode && t2) t2 = z - t2; - return SCM_MAKINUM(sgn ? -t2 : t2); - } - { -#ifndef SCM_DIGSTOOBIG - unsigned long t2 = scm_pseudolong(z); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&t2, - SCM_DIGSPERLONG, sgn, mode); -#else - SCM_BIGDIG t2[SCM_DIGSPERLONG]; - scm_longdigs(z, t2); - return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), t2, SCM_DIGSPERLONG, sgn, mode); -#endif - } -} - - -SCM -scm_divbigbig(x, nx, y, ny, sgn, modes) - SCM_BIGDIG *x; - scm_sizet nx; - SCM_BIGDIG *y; - scm_sizet ny; - int sgn; - int modes; -{ - /* modes description - 0 remainder - 1 scm_modulo - 2 quotient - 3 quotient but returns 0 if division is not exact. */ - scm_sizet i = 0, j = 0; - long num = 0; - unsigned long t2 = 0; - SCM z, newy; - SCM_BIGDIG d = 0, qhat, *zds, *yds; - /* algorithm requires nx >= ny */ - if (nx < ny) - switch (modes) { - case 0: /* remainder -- just return x */ - z = scm_mkbig(nx, sgn); zds = SCM_BDIGITS(z); - do {zds[i] = x[i];} while (++i < nx); - return z; - case 1: /* scm_modulo -- return y-x */ - z = scm_mkbig(ny, sgn); zds = SCM_BDIGITS(z); - do { - num += (long) y[i] - x[i]; - if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;} - else {zds[i] = num; num = 0;} - } while (++i < nx); - while (i < ny) { - num += y[i]; - if (num < 0) {zds[i++] = num + SCM_BIGRAD; num = -1;} - else {zds[i++] = num; num = 0;} - } - goto doadj; - case 2: return SCM_INUM0; /* quotient is zero */ - case 3: return 0; /* the division is not exact */ - } - - z = scm_mkbig(nx==ny ? nx+2 : nx+1, sgn); zds = SCM_BDIGITS(z); - if (nx==ny) zds[nx+1] = 0; - while(!y[ny-1]) ny--; /* in case y came in as a psuedolong */ - if (y[ny-1] < (SCM_BIGRAD>>1)) { /* normalize operands */ - d = SCM_BIGRAD/(y[ny-1]+1); - newy = scm_mkbig(ny, 0); yds = SCM_BDIGITS(newy); - while(j < ny) - {t2 += (unsigned long) y[j]*d; yds[j++] = SCM_BIGLO(t2); t2 = SCM_BIGDN(t2);} - y = yds; j = 0; t2 = 0; - while(j < nx) - {t2 += (unsigned long) x[j]*d; zds[j++] = SCM_BIGLO(t2); t2 = SCM_BIGDN(t2);} - zds[j] = t2; - } - else {zds[j = nx] = 0; while (j--) zds[j] = x[j];} - j = nx==ny ? nx+1 : nx; /* dividend needs more digits than divisor */ - do { /* loop over digits of quotient */ - if (zds[j]==y[ny-1]) qhat = SCM_BIGRAD-1; - else qhat = (SCM_BIGUP(zds[j]) + zds[j-1])/y[ny-1]; - if (!qhat) continue; - i = 0; num = 0; t2 = 0; - do { /* multiply and subtract */ - t2 += (unsigned long) y[i] * qhat; - num += zds[j - ny + i] - SCM_BIGLO(t2); - if (num < 0) {zds[j - ny + i] = num + SCM_BIGRAD; num = -1;} - else {zds[j - ny + i] = num; num = 0;} - t2 = SCM_BIGDN(t2); - } while (++i < ny); - num += zds[j - ny + i] - t2; /* borrow from high digit; don't update */ - while (num) { /* "add back" required */ - i = 0; num = 0; qhat--; - do { - num += (long) zds[j - ny + i] + y[i]; - zds[j - ny + i] = SCM_BIGLO(num); - num = SCM_BIGDN(num); - } while (++i < ny); - num--; - } - if (modes & 2) zds[j] = qhat; - } while (--j >= ny); - switch (modes) { - case 3: /* check that remainder==0 */ - for(j = ny;j && !zds[j-1];--j) ; if (j) return 0; - case 2: /* move quotient down in z */ - j = (nx==ny ? nx+2 : nx+1) - ny; - for (i = 0;i < j;i++) zds[i] = zds[i+ny]; - ny = i; - break; - case 1: /* subtract for scm_modulo */ - i = 0; num = 0; j = 0; - do {num += y[i] - zds[i]; - j = j | zds[i]; - if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;} - else {zds[i] = num; num = 0;} - } while (++i < ny); - if (!j) return SCM_INUM0; - case 0: /* just normalize remainder */ - if (d) scm_divbigdig(zds, ny, d); - } - doadj: - for(j = ny;j && !zds[j-1];--j) ; - if (j * SCM_BITSPERDIG <= sizeof(SCM)*SCM_CHAR_BIT) - if SCM_INUMP(z = scm_big2inum(z, j)) return z; - return scm_adjbig(z, j); -} -#endif - - - - - -/*** NUMBERS -> STRINGS ***/ -#ifdef SCM_FLOATS -int scm_dblprec; -static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5, - 5e-6, 5e-7, 5e-8, 5e-9, 5e-10, - 5e-11,5e-12,5e-13,5e-14,5e-15, - 5e-16,5e-17,5e-18,5e-19,5e-20}; - - - - -static scm_sizet idbl2str SCM_P ((double f, char *a)); - -static scm_sizet -idbl2str(f, a) - double f; - char *a; -{ - int efmt, dpt, d, i, wp = scm_dblprec; - scm_sizet ch = 0; - int exp = 0; - - if (f == 0.0) goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/ - if (f < 0.0) {f = -f;a[ch++]='-';} - else if (f > 0.0) ; - else goto funny; - if (IS_INF(f)) - { - if (ch == 0) a[ch++]='+'; - funny: a[ch++]='#'; a[ch++]='.'; a[ch++]='#'; return ch; - } -# ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from - make-uniform-vector, from causing infinite loops. */ - while (f < 1.0) {f *= 10.0; if (exp-- < DBL_MIN_10_EXP) goto funny;} - while (f > 10.0) {f *= 0.10; if (exp++ > DBL_MAX_10_EXP) goto funny;} -# else - while (f < 1.0) {f *= 10.0; exp--;} - while (f > 10.0) {f /= 10.0; exp++;} -# endif - if (f+fx[wp] >= 10.0) {f = 1.0; exp++;} - zero: -# ifdef ENGNOT - dpt = (exp+9999)%3; - exp -= dpt++; - efmt = 1; -# else - efmt = (exp < -3) || (exp > wp+2); - if (!efmt) - if (exp < 0) { - a[ch++] = '0'; - a[ch++] = '.'; - dpt = exp; - while (++dpt) a[ch++] = '0'; - } else - dpt = exp+1; - else - dpt = 1; -# endif - - do { - d = f; - f -= d; - a[ch++] = d+'0'; - if (f < fx[wp]) break; - if (f+fx[wp] >= 1.0) { - a[ch-1]++; - break; - } - f *= 10.0; - if (!(--dpt)) a[ch++] = '.'; - } while (wp--); - - if (dpt > 0) -# ifndef ENGNOT - if ((dpt > 4) && (exp > 6)) { - d = (a[0]=='-'?2:1); - for (i = ch++; i > d; i--) - a[i] = a[i-1]; - a[d] = '.'; - efmt = 1; - } else -# endif - { - while (--dpt) a[ch++] = '0'; - a[ch++] = '.'; - } - if (a[ch-1]=='.') a[ch++]='0'; /* trailing zero */ - if (efmt && exp) { - a[ch++] = 'e'; - if (exp < 0) { - exp = -exp; - a[ch++] = '-'; - } - for (i = 10; i <= exp; i *= 10); - for (i /= 10; i; i /= 10) { - a[ch++] = exp/i + '0'; - exp %= i; - } - } - return ch; -} - - -static scm_sizet iflo2str SCM_P ((SCM flt, char *str)); - -static scm_sizet -iflo2str(flt, str) - SCM flt; - char *str; -{ - scm_sizet i; -# ifdef SCM_SINGLES - if SCM_SINGP(flt) i = idbl2str(SCM_FLO(flt), str); - else -# endif - i = idbl2str(SCM_REAL(flt), str); - if SCM_CPLXP(flt) { - if(0 <= SCM_IMAG(flt)) /* jeh */ - str[i++] = '+'; /* jeh */ - i += idbl2str(SCM_IMAG(flt), &str[i]); - str[i++] = 'i'; - } - return i; -} -#endif /* SCM_FLOATS */ - - -scm_sizet -scm_iint2str(num, rad, p) - long num; - int rad; - char *p; -{ - scm_sizet j; - register int i = 1, d; - register long n = num; - if (n < 0) {n = -n; i++;} - for (n /= rad;n > 0;n /= rad) i++; - j = i; - n = num; - if (n < 0) {n = -n; *p++ = '-'; i--;} - while (i--) { - d = n % rad; - n /= rad; - p[i] = d + ((d < 10) ? '0' : 'a' - 10); - } - return j; -} - - -#ifdef SCM_BIGDIG - -static SCM big2str SCM_P ((SCM b, register unsigned int radix)); - -static SCM -big2str(b, radix) - SCM b; - register unsigned int radix; -{ - SCM t = scm_copybig(b, 0); /* sign of temp doesn't matter */ - register SCM_BIGDIG *ds = SCM_BDIGITS(t); - scm_sizet i = SCM_NUMDIGS(t); - scm_sizet j = radix==16 ? (SCM_BITSPERDIG*i)/4+2 - : radix >= 10 ? (SCM_BITSPERDIG*i*241L)/800+2 - : (SCM_BITSPERDIG*i)+2; - scm_sizet k = 0; - scm_sizet radct = 0; - scm_sizet ch; /* jeh */ - SCM_BIGDIG radpow = 1, radmod = 0; - SCM ss = scm_makstr((long)j, 0); - char *s = SCM_CHARS(ss), c; - while ((long) radpow * radix < SCM_BIGRAD) { - radpow *= radix; - radct++; - } - s[0] = scm_tc16_bigneg==SCM_TYP16(b) ? '-' : '+'; - while ((i || radmod) && j) { - if (k == 0) { - radmod = (SCM_BIGDIG)scm_divbigdig(ds, i, radpow); - k = radct; - if (!ds[i-1]) i--; - } - c = radmod % radix; radmod /= radix; k--; - s[--j] = c < 10 ? c + '0' : c + 'a' - 10; - } - ch = s[0] == '-' ? 1 : 0; /* jeh */ - if (ch < j) { /* jeh */ - for(i = j;j < SCM_LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */ - scm_vector_set_length_x(ss, (SCM)SCM_MAKINUM(ch+SCM_LENGTH(ss)-i)); /* jeh */ - } - return ss; -} -#endif - - -SCM_PROC(s_number_to_string, "number->string", 1, 1, 0, scm_number_to_string); - -SCM -scm_number_to_string(x, radix) - SCM x; - SCM radix; -{ - if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L); - else SCM_ASSERT(SCM_INUMP(radix), radix, SCM_ARG2, s_number_to_string); -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { - char num_buf[SCM_FLOBUFLEN]; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) return big2str(x, (unsigned int)SCM_INUM(radix)); -# ifndef RECKLESS - if (!(SCM_INEXP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_number_to_string); -# endif -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_INEXP(x), x, SCM_ARG1, s_number_to_string); -# endif - return scm_makfromstr(num_buf, iflo2str(x, num_buf), 0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_number_to_string); - return big2str(x, (unsigned int)SCM_INUM(radix)); - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_number_to_string); -# endif -#endif - { - char num_buf[SCM_INTBUFLEN]; - return scm_makfromstr(num_buf, - scm_iint2str(SCM_INUM(x), (int)SCM_INUM(radix), num_buf), 0); - } -} - - -/* These print routines are stubbed here so that scm_repl.c doesn't need - SCM_FLOATS or SCM_BIGDIGs conditionals */ - -int -scm_floprint(sexp, port, pstate) - SCM sexp; - SCM port; - scm_print_state *pstate; -{ -#ifdef SCM_FLOATS - char num_buf[SCM_FLOBUFLEN]; - scm_gen_write (scm_regular_string, num_buf, iflo2str(sexp, num_buf), port); -#else - scm_ipruk("float", sexp, port); -#endif - return !0; -} - - - -int -scm_bigprint(exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ -#ifdef SCM_BIGDIG - exp = big2str(exp, (unsigned int)10); - scm_gen_write (scm_regular_string, SCM_CHARS(exp), (scm_sizet)SCM_LENGTH(exp), port); -#else - scm_ipruk("bignum", exp, port); -#endif - return !0; -} -/*** END nums->strs ***/ - -/*** STRINGS -> NUMBERS ***/ - -static SCM scm_small_istr2int SCM_P ((char *str, long len, long radix)); - -static SCM -scm_small_istr2int(str, len, radix) - char *str; - long len; - long radix; -{ - register long n = 0, ln; - register int c; - register int i = 0; - int lead_neg = 0; - if (0 >= len) return SCM_BOOL_F; /* zero scm_length */ - switch (*str) { /* leading sign */ - case '-': lead_neg = 1; - case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */ - } - - do { - switch (c = str[i++]) { - case DIGITS: - c = c - '0'; - goto accumulate; - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - c = c-'A'+10; - goto accumulate; - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - c = c-'a'+10; - accumulate: - if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */ - ln = n; - n = n * radix - c; - /* Negation is a workaround for HP700 cc bug */ - if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM)) goto ovfl; - break; - default: - return SCM_BOOL_F; /* not a digit */ - } - } while (i < len); - if (!lead_neg) if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM) goto ovfl; - return SCM_MAKINUM(n); - ovfl: /* overflow scheme integer */ - return SCM_BOOL_F; -} - - - -SCM -scm_istr2int(str, len, radix) - char *str; - long len; - long radix; -{ - scm_sizet j; - register scm_sizet k, blen = 1; - scm_sizet i = 0; - int c; - SCM res; - register SCM_BIGDIG *ds; - register unsigned long t2; - - if (0 >= len) return SCM_BOOL_F; /* zero scm_length */ - - /* Short numbers we parse directly into an int, to avoid the overhead - of creating a bignum. */ - if (len < 6) - return scm_small_istr2int (str, len, radix); - - if (16==radix) j = 1+(4*len*sizeof(char))/(SCM_BITSPERDIG); - else if (10 <= radix) - j = 1+(84*len*sizeof(char))/(SCM_BITSPERDIG*25); - else j = 1+(len*sizeof(char))/(SCM_BITSPERDIG); - switch (str[0]) { /* leading sign */ - case '-': - case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */ - } - res = scm_mkbig(j, '-'==str[0]); - ds = SCM_BDIGITS(res); - for (k = j;k--;) ds[k] = 0; - do { - switch (c = str[i++]) { - case DIGITS: - c = c - '0'; - goto accumulate; - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - c = c-'A'+10; - goto accumulate; - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - c = c-'a'+10; - accumulate: - if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */ - k = 0; - t2 = c; - moretodo: - while(k < blen) { - /* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/ - t2 += ds[k]*radix; - ds[k++] = SCM_BIGLO(t2); - t2 = SCM_BIGDN(t2); - } - if (blen > j) - scm_num_overflow ("bignum"); - if (t2) {blen++; goto moretodo;} - break; - default: - return SCM_BOOL_F; /* not a digit */ - } - } while (i < len); - if (blen * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM)) - if SCM_INUMP(res = scm_big2inum(res, blen)) return res; - if (j==blen) return res; - return scm_adjbig(res, blen); -} - -#ifdef SCM_FLOATS - -SCM -scm_istr2flo(str, len, radix) - char *str; - long len; - long radix; -{ - register int c, i = 0; - double lead_sgn; - double res = 0.0, tmp = 0.0; - int flg = 0; - int point = 0; - SCM second; - - if (i >= len) return SCM_BOOL_F; /* zero scm_length */ - - switch (*str) { /* leading sign */ - case '-': lead_sgn = -1.0; i++; break; - case '+': lead_sgn = 1.0; i++; break; - default : lead_sgn = 0.0; - } - if (i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */ - - if (str[i]=='i' || str[i]=='I') { /* handle `+i' and `-i' */ - if (lead_sgn==0.0) return SCM_BOOL_F; /* must have leading sign */ - if (++i < len) return SCM_BOOL_F; /* `i' not last character */ - return scm_makdbl(0.0, lead_sgn); - } - do { /* check initial digits */ - switch (c = str[i]) { - case DIGITS: - c = c - '0'; - goto accum1; - case 'D': case 'E': case 'F': - if (radix==10) goto out1; /* must be exponent */ - case 'A': case 'B': case 'C': - c = c-'A'+10; - goto accum1; - case 'd': case 'e': case 'f': - if (radix==10) goto out1; - case 'a': case 'b': case 'c': - c = c-'a'+10; - accum1: - if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */ - res = res * radix + c; - flg = 1; /* res is valid */ - break; - default: - goto out1; - } - } while (++i < len); - out1: - - /* if true, then we did see a digit above, and res is valid */ - if (i==len) goto done; - - /* By here, must have seen a digit, - or must have next char be a `.' with radix==10 */ - if (!flg) - if (!(str[i]=='.' && radix==10)) - return SCM_BOOL_F; - - while (str[i]=='#') { /* optional sharps */ - res *= radix; - if (++i==len) goto done; - } - - if (str[i]=='/') { - while (++i < len) { - switch (c = str[i]) { - case DIGITS: - c = c - '0'; - goto accum2; - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - c = c-'A'+10; - goto accum2; - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - c = c-'a'+10; - accum2: - if (c >= radix) return SCM_BOOL_F; - tmp = tmp * radix + c; - break; - default: - goto out2; - } - } - out2: - if (tmp==0.0) return SCM_BOOL_F; /* `slash zero' not allowed */ - if (i < len) - while (str[i]=='#') { /* optional sharps */ - tmp *= radix; - if (++i==len) break; - } - res /= tmp; - goto done; - } - - if (str[i]=='.') { /* decimal point notation */ - if (radix != 10) return SCM_BOOL_F; /* must be radix 10 */ - while (++i < len) { - switch (c = str[i]) { - case DIGITS: - point--; - res = res*10.0 + c-'0'; - flg = 1; - break; - default: - goto out3; - } - } - out3: - if (!flg) return SCM_BOOL_F; /* no digits before or after decimal point */ - if (i==len) goto adjust; - while (str[i]=='#') { /* ignore remaining sharps */ - if (++i==len) goto adjust; - } - } - - switch (str[i]) { /* exponent */ - case 'd': case 'D': - case 'e': case 'E': - case 'f': case 'F': - case 'l': case 'L': - case 's': case 'S': { - int expsgn = 1, expon = 0; - if (radix != 10) return SCM_BOOL_F; /* only in radix 10 */ - if (++i==len) return SCM_BOOL_F; /* bad exponent */ - switch (str[i]) { - case '-': expsgn=(-1); - case '+': if (++i==len) return SCM_BOOL_F; /* bad exponent */ - } - if (str[i] < '0' || str[i] > '9') return SCM_BOOL_F; /* bad exponent */ - do { - switch (c = str[i]) { - case DIGITS: - expon = expon*10 + c-'0'; - if (expon > MAXEXP) return SCM_BOOL_F; /* exponent too large */ - break; - default: - goto out4; - } - } while (++i < len); - out4: - point += expsgn*expon; - } - } - - adjust: - if (point >= 0) - while (point--) res *= 10.0; - else -# ifdef _UNICOS - while (point++) res *= 0.1; -# else - while (point++) res /= 10.0; -# endif - - done: - /* at this point, we have a legitimate floating point result */ - if (lead_sgn==-1.0) res = -res; - if (i==len) return scm_makdbl(res, 0.0); - - if (str[i]=='i' || str[i]=='I') { /* pure imaginary number */ - if (lead_sgn==0.0) return SCM_BOOL_F; /* must have leading sign */ - if (++i < len) return SCM_BOOL_F; /* `i' not last character */ - return scm_makdbl(0.0, res); - } - - switch (str[i++]) { - case '-': lead_sgn = -1.0; break; - case '+': lead_sgn = 1.0; break; - case '@': { /* polar input for complex number */ - /* get a `real' for scm_angle */ - second = scm_istr2flo(&str[i], (long)(len-i), radix); - if (!(SCM_INEXP(second))) return SCM_BOOL_F; /* not `real' */ - if (SCM_CPLXP(second)) return SCM_BOOL_F; /* not `real' */ - tmp = SCM_REALPART(second); - return scm_makdbl(res*cos(tmp), res*sin(tmp)); - } - default: return SCM_BOOL_F; - } - - /* at this point, last char must be `i' */ - if (str[len-1] != 'i' && str[len-1] != 'I') return SCM_BOOL_F; - /* handles `x+i' and `x-i' */ - if (i==(len-1)) return scm_makdbl(res, lead_sgn); - /* get a `ureal' for complex part */ - second = scm_istr2flo(&str[i], (long)((len-i)-1), radix); - if (!(SCM_INEXP(second))) return SCM_BOOL_F; /* not `ureal' */ - if (SCM_CPLXP(second)) return SCM_BOOL_F; /* not `ureal' */ - tmp = SCM_REALPART(second); - if (tmp < 0.0) return SCM_BOOL_F; /* not `ureal' */ - return scm_makdbl(res, (lead_sgn*tmp)); -} -#endif /* SCM_FLOATS */ - - - -SCM -scm_istring2number(str, len, radix) - char *str; - long len; - long radix; -{ - int i = 0; - char ex = 0; - char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */ - SCM res; - if (len==1) - if (*str=='+' || *str=='-') /* Catches lone `+' and `-' for speed */ - return SCM_BOOL_F; - - while ((len-i) >= 2 && str[i]=='#' && ++i) - switch (str[i++]) { - case 'b': case 'B': if (rx_p++) return SCM_BOOL_F; radix = 2; break; - case 'o': case 'O': if (rx_p++) return SCM_BOOL_F; radix = 8; break; - case 'd': case 'D': if (rx_p++) return SCM_BOOL_F; radix = 10; break; - case 'x': case 'X': if (rx_p++) return SCM_BOOL_F; radix = 16; break; - case 'i': case 'I': if (ex_p++) return SCM_BOOL_F; ex = 2; break; - case 'e': case 'E': if (ex_p++) return SCM_BOOL_F; ex = 1; break; - default: return SCM_BOOL_F; - } - - switch (ex) { - case 1: - return scm_istr2int(&str[i], len-i, radix); - case 0: - res = scm_istr2int(&str[i], len-i, radix); - if SCM_NFALSEP(res) return res; -#ifdef SCM_FLOATS - case 2: return scm_istr2flo(&str[i], len-i, radix); -#endif - } - return SCM_BOOL_F; -} - - -SCM_PROC(s_string_to_number, "string->number", 1, 1, 0, scm_string_to_number); - -SCM -scm_string_to_number(str, radix) - SCM str; - SCM radix; -{ - SCM answer; - if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L); - else SCM_ASSERT(SCM_INUMP(radix), radix, SCM_ARG2, s_string_to_number); - SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, s_string_to_number); - answer = scm_istring2number(SCM_ROCHARS(str), SCM_ROLENGTH(str), SCM_INUM(radix)); - return scm_return_first (answer, str); -} -/*** END strs->nums ***/ - -#ifdef SCM_FLOATS - -SCM -scm_makdbl (x, y) - double x; - double y; -{ - SCM z; - if ((y==0.0) && (x==0.0)) return scm_flo0; - SCM_NEWCELL(z); - SCM_DEFER_INTS; - if (y==0.0) { -# ifdef SCM_SINGLES - float fx = x; -# ifndef SCM_SINGLESONLY - if ((-FLTMAX < x) && (x < FLTMAX) && (fx==x)) -# endif - { - SCM_SETCAR (z, scm_tc_flo); - SCM_FLO(z) = x; - SCM_ALLOW_INTS; - return z; - } -# endif/* def SCM_SINGLES */ - SCM_SETCDR (z, (SCM)scm_must_malloc(1L*sizeof(double), "real")); - SCM_SETCAR (z, scm_tc_dblr); - } - else { - SCM_SETCDR (z, (SCM)scm_must_malloc(2L*sizeof(double), "complex")); - SCM_SETCAR (z, scm_tc_dblc); - SCM_IMAG(z) = y; - } - SCM_REAL(z) = x; - SCM_ALLOW_INTS; - return z; -} -#endif - - - -SCM -scm_bigequal(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_BIGDIG - if (0==scm_bigcomp(x, y)) return SCM_BOOL_T; -#endif - return SCM_BOOL_F; -} - - - -SCM -scm_floequal(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F; - if (!(SCM_CPLXP(x) && (SCM_IMAG(x) != SCM_IMAG(y)))) return SCM_BOOL_T; -#endif - return SCM_BOOL_F; -} - - - - -SCM_PROC(s_number_p, "number?", 1, 0, 0, scm_number_p); -SCM_PROC(s_complex_p, "complex?", 1, 0, 0, scm_number_p); - -SCM -scm_number_p(x) - SCM x; -{ - if SCM_INUMP(x) return SCM_BOOL_T; -#ifdef SCM_FLOATS - if (SCM_NIMP(x) && SCM_NUMP(x)) return SCM_BOOL_T; -#else -# ifdef SCM_BIGDIG - if (SCM_NIMP(x) && SCM_NUMP(x)) return SCM_BOOL_T; -# endif -#endif - return SCM_BOOL_F; -} - - - -#ifdef SCM_FLOATS -SCM_PROC(s_real_p, "real?", 1, 0, 0, scm_real_p); -SCM_PROC(s_rational_p, "rational?", 1, 0, 0, scm_real_p); - -SCM -scm_real_p(x) - SCM x; -{ - if (SCM_INUMP(x)) - return SCM_BOOL_T; - if (SCM_IMP(x)) - return SCM_BOOL_F; - if (SCM_REALP(x)) - return SCM_BOOL_T; -# ifdef SCM_BIGDIG - if (SCM_BIGP(x)) - return SCM_BOOL_T; -# endif - return SCM_BOOL_F; -} - - - -SCM_PROC(s_int_p, "integer?", 1, 0, 0, scm_integer_p); - -SCM -scm_integer_p(x) - SCM x; -{ - double r; - if SCM_INUMP(x) return SCM_BOOL_T; - if SCM_IMP(x) return SCM_BOOL_F; -# ifdef SCM_BIGDIG - if SCM_BIGP(x) return SCM_BOOL_T; -# endif - if (!SCM_INEXP(x)) return SCM_BOOL_F; - if (SCM_CPLXP(x)) return SCM_BOOL_F; - r = SCM_REALPART(x); - if (r==floor(r)) return SCM_BOOL_T; - return SCM_BOOL_F; -} - - - -#endif /* SCM_FLOATS */ - -SCM_PROC(s_inexact_p, "inexact?", 1, 0, 0, scm_inexact_p); - -SCM -scm_inexact_p(x) - SCM x; -{ -#ifdef SCM_FLOATS - if (SCM_NIMP(x) && SCM_INEXP(x)) return SCM_BOOL_T; -#endif - return SCM_BOOL_F; -} - - - - -SCM_PROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p); - -SCM -scm_num_eq_p (x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - SCM t; - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG -# ifndef RECKLESS - if (!(SCM_NIMP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_eq_p); -# endif - if SCM_BIGP(x) { - if SCM_INUMP(y) return SCM_BOOL_F; - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F; - SCM_ASRTGO(SCM_INEXP(y), bady); - bigreal: - return (SCM_REALP(y) && (scm_big2dbl(x)==SCM_REALPART(y))) ? SCM_BOOL_T : SCM_BOOL_F; - } - SCM_ASRTGO(SCM_INEXP(x), badx); -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_INEXP(x), x, SCM_ARG1, s_eq_p); -# endif - if SCM_INUMP(y) {t = x; x = y; y = t; goto realint;} -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;} - SCM_ASRTGO(SCM_INEXP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady); -# endif - if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F; - if SCM_CPLXP(x) - return (SCM_CPLXP(y) && (SCM_IMAG(x)==SCM_IMAG(y))) ? SCM_BOOL_T : SCM_BOOL_F; - return SCM_CPLXP(y) ? SCM_BOOL_F : SCM_BOOL_T; - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return SCM_BOOL_F; -# ifndef RECKLESS - if (!(SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p); -# endif -# endif - realint: - return (SCM_REALP(y) && (((double)SCM_INUM(x))==SCM_REALPART(y))) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_eq_p); - if SCM_INUMP(y) return SCM_BOOL_F; - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F; - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p); -# endif - return SCM_BOOL_F; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_eq_p); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_eq_p); -# endif -#endif - return ((long)x==(long)y) ? SCM_BOOL_T : SCM_BOOL_F; -} - - - -SCM_PROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p); - -SCM -scm_less_p(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG -# ifndef RECKLESS - if (!(SCM_NIMP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_less_p); -# endif - if SCM_BIGP(x) { - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? SCM_BOOL_T : SCM_BOOL_F; - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (1==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F; - SCM_ASRTGO(SCM_REALP(y), bady); - return (scm_big2dbl(x) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F; - } - SCM_ASRTGO(SCM_REALP(x), badx); -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_less_p); -# endif - if (SCM_INUMP(y)) - return (SCM_REALPART(x) < ((double)SCM_INUM(y))) ? SCM_BOOL_T : SCM_BOOL_F; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (SCM_REALPART(x) < scm_big2dbl(y)) ? SCM_BOOL_T : SCM_BOOL_F; - SCM_ASRTGO(SCM_REALP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady); -# endif - return (SCM_REALPART(x) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F; - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return SCM_BIGSIGN(y) ? SCM_BOOL_F : SCM_BOOL_T; -# ifndef RECKLESS - if (!(SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_less_p); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_less_p); -# endif -# endif - return (((double)SCM_INUM(x)) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_less_p); - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? SCM_BOOL_T : SCM_BOOL_F; - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return (1==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F; - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_less_p); -# endif - return SCM_BIGSIGN(y) ? SCM_BOOL_F : SCM_BOOL_T; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_less_p); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_less_p); -# endif -#endif - return ((long)x < (long)y) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC1 (s_gr_p, ">", scm_tc7_rpsubr, scm_gr_p); - -SCM -scm_gr_p(x, y) - SCM x; - SCM y; -{ - return scm_less_p(y, x); -} - - - -SCM_PROC1 (s_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p); - -SCM -scm_leq_p(x, y) - SCM x; - SCM y; -{ - return SCM_BOOL_NOT(scm_less_p(y, x)); -} - - - -SCM_PROC1 (s_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p); - -SCM -scm_geq_p(x, y) - SCM x; - SCM y; -{ - return SCM_BOOL_NOT(scm_less_p(x, y)); -} - - - -SCM_PROC(s_zero_p, "zero?", 1, 0, 0, scm_zero_p); - -SCM -scm_zero_p(z) - SCM z; -{ -#ifdef SCM_FLOATS - if SCM_NINUMP(z) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) return SCM_BOOL_F; -# ifndef RECKLESS - if (!(SCM_INEXP(z))) - badz: scm_wta(z, (char *)SCM_ARG1, s_zero_p); -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_zero_p); -# endif - return (z==scm_flo0) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(z) { - SCM_ASSERT(SCM_NIMP(z) && SCM_BIGP(z), z, SCM_ARG1, s_zero_p); - return SCM_BOOL_F; - } -# else - SCM_ASSERT(SCM_INUMP(z), z, SCM_ARG1, s_zero_p); -# endif -#endif - return (z==SCM_INUM0) ? SCM_BOOL_T: SCM_BOOL_F; -} - - - -SCM_PROC(s_positive_p, "positive?", 1, 0, 0, scm_positive_p); - -SCM -scm_positive_p(x) - SCM x; -{ -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F; -# ifndef RECKLESS - if (!(SCM_REALP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_positive_p); -# endif -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_positive_p); -# endif - return (SCM_REALPART(x) > 0.0) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_positive_p); - return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_positive_p); -# endif -#endif - return (x > SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F; -} - - - -SCM_PROC(s_negative_p, "negative?", 1, 0, 0, scm_negative_p); - -SCM -scm_negative_p(x) - SCM x; -{ -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_F : SCM_BOOL_T; -# ifndef RECKLESS - if (!(SCM_REALP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_negative_p); -# endif -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_negative_p); -# endif - return (SCM_REALPART(x) < 0.0) ? SCM_BOOL_T : SCM_BOOL_F; - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_negative_p); - return (SCM_TYP16(x)==scm_tc16_bigneg) ? SCM_BOOL_T : SCM_BOOL_F; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_negative_p); -# endif -#endif - return (x < SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC1 (s_max, "max", scm_tc7_asubr, scm_max); - -SCM -scm_max(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - double z; -#endif - if SCM_UNBNDP(y) { -#ifndef RECKLESS - if (!(SCM_NUMBERP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_max); -#endif - return x; - } -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) { - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? y : x; - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (1==scm_bigcomp(x, y)) ? y : x; - SCM_ASRTGO(SCM_REALP(y), bady); - z = scm_big2dbl(x); - return (z < SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0); - } - SCM_ASRTGO(SCM_REALP(x), badx); -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_max); -# endif - if (SCM_INUMP(y)) - return (SCM_REALPART(x) < (z = SCM_INUM(y))) ? scm_makdbl(z, 0.0) : x; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if (SCM_BIGP(y)) - return (SCM_REALPART(x) < (z = scm_big2dbl(y))) ? scm_makdbl(z, 0.0) : x; - SCM_ASRTGO(SCM_REALP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady); -# endif - return (SCM_REALPART(x) < SCM_REALPART(y)) ? y : x; - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return SCM_BIGSIGN(y) ? x : y; -# ifndef RECKLESS - if (!(SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_max); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_max); -# endif -# endif - return ((z = SCM_INUM(x)) < SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_max); - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? y : x; - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return (1==scm_bigcomp(x, y)) ? y : x; - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_max); -# endif - return SCM_BIGSIGN(y) ? x : y; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_max); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_max); -# endif -#endif - return ((long)x < (long)y) ? y : x; -} - - - - -SCM_PROC1 (s_min, "min", scm_tc7_asubr, scm_min); - -SCM -scm_min(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - double z; -#endif - if SCM_UNBNDP(y) { -#ifndef RECKLESS - if (!(SCM_NUMBERP(x))) - badx:scm_wta(x, (char *)SCM_ARG1, s_min); -#endif - return x; - } -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) { - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? x : y; - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (-1==scm_bigcomp(x, y)) ? y : x; - SCM_ASRTGO(SCM_REALP(y), bady); - z = scm_big2dbl(x); - return (z > SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0); - } - SCM_ASRTGO(SCM_REALP(x), badx); -# else - SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_min); -# endif - if SCM_INUMP(y) return (SCM_REALPART(x) > (z = SCM_INUM(y))) ? scm_makdbl(z, 0.0) : x; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return (SCM_REALPART(x) > (z = scm_big2dbl(y))) ? scm_makdbl(z, 0.0) : x; - SCM_ASRTGO(SCM_REALP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady); -# endif - return (SCM_REALPART(x) > SCM_REALPART(y)) ? y : x; - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return SCM_BIGSIGN(y) ? y : x; -# ifndef RECKLESS - if (!(SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_min); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_REALP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_min); -# endif -# endif - return ((z = SCM_INUM(x)) > SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_min); - if SCM_INUMP(y) return SCM_BIGSIGN(x) ? x : y; - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return (-1==scm_bigcomp(x, y)) ? y : x; - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_min); -# endif - return SCM_BIGSIGN(y) ? y : x; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_min); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_min); -# endif -#endif - return ((long)x > (long)y) ? y : x; -} - - - - -SCM_PROC1 (s_sum, "+", scm_tc7_asubr, scm_sum); - -SCM -scm_sum(x, y) - SCM x; - SCM y; -{ - if SCM_UNBNDP(y) { - if SCM_UNBNDP(x) return SCM_INUM0; -#ifndef RECKLESS - if (!(SCM_NUMBERP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_sum); -#endif - return x; - } -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { - SCM t; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) { - if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;} - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) { - if (SCM_NUMDIGS(x) > SCM_NUMDIGS(y)) {t = x; x = y; y = t;} - return scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0); - } - SCM_ASRTGO(SCM_INEXP(y), bady); - bigreal: return scm_makdbl(scm_big2dbl(x)+SCM_REALPART(y), SCM_CPLXP(y)?SCM_IMAG(y):0.0); - } - SCM_ASRTGO(SCM_INEXP(x), badx); -# else - SCM_ASRTGO(SCM_NIMP(x) && SCM_INEXP(x), badx); -# endif - if SCM_INUMP(y) {t = x; x = y; y = t; goto intreal;} -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;} -# ifndef RECKLESS - else if (!(SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_sum); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_sum); -# endif -# endif - { double i = 0.0; - if SCM_CPLXP(x) i = SCM_IMAG(x); - if SCM_CPLXP(y) i += SCM_IMAG(y); - return scm_makdbl(SCM_REALPART(x)+SCM_REALPART(y), i); } - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) - intbig: { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_addbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -# endif - } - SCM_ASRTGO(SCM_INEXP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady); -# endif - intreal: return scm_makdbl(SCM_INUM(x)+SCM_REALPART(y), SCM_CPLXP(y)?SCM_IMAG(y):0.0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM t; - SCM_ASRTGO(SCM_NIMP(x) && SCM_BIGP(x), badx); - if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;} - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - if (SCM_NUMDIGS(x) > SCM_NUMDIGS(y)) {t = x; x = y; y = t;} - return scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0); - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_sum); -# endif - intbig: { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_addbig(&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -# endif - } - } -# else - SCM_ASRTGO(SCM_INUMP(x), badx); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_sum); -# endif -#endif - x = SCM_INUM(x)+SCM_INUM(y); - if SCM_FIXABLE(x) return SCM_MAKINUM(x); -#ifdef SCM_BIGDIG - return scm_long2big(x); -#else -# ifdef SCM_FLOATS - return scm_makdbl((double)x, 0.0); -# else - scm_num_overflow (s_sum); - return SCM_UNSPECIFIED; -# endif -#endif -} - - - - -SCM_PROC1 (s_difference, "-", scm_tc7_asubr, scm_difference); - -SCM -scm_difference(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { -# ifndef RECKLESS - if (!(SCM_NIMP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_difference); -# endif - if SCM_UNBNDP(y) { -# ifdef SCM_BIGDIG - if SCM_BIGP(x) { - x = scm_copybig(x, !SCM_BIGSIGN(x)); - return SCM_NUMDIGS(x) * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM) ? - scm_big2inum(x, SCM_NUMDIGS(x)) : x; - } -# endif - SCM_ASRTGO(SCM_INEXP(x), badx); - return scm_makdbl(-SCM_REALPART(x), SCM_CPLXP(x)?-SCM_IMAG(x):0.0); - } - if SCM_INUMP(y) return scm_sum(x, SCM_MAKINUM(-SCM_INUM(y))); -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(x) { - if SCM_BIGP(y) return (SCM_NUMDIGS(x) < SCM_NUMDIGS(y)) ? - scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0x0100) : - scm_addbig(SCM_BDIGITS(y), SCM_NUMDIGS(y), SCM_BIGSIGN(y) ^ 0x0100, x, 0); - SCM_ASRTGO(SCM_INEXP(y), bady); - return scm_makdbl(scm_big2dbl(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0); - } - SCM_ASRTGO(SCM_INEXP(x), badx); - if SCM_BIGP(y) return scm_makdbl(SCM_REALPART(x)-scm_big2dbl(y), SCM_CPLXP(x)?SCM_IMAG(x):0.0); - SCM_ASRTGO(SCM_INEXP(y), bady); -# else - SCM_ASRTGO(SCM_INEXP(x), badx); - SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady); -# endif - if SCM_CPLXP(x) - if SCM_CPLXP(y) - return scm_makdbl(SCM_REAL(x)-SCM_REAL(y), SCM_IMAG(x)-SCM_IMAG(y)); - else - return scm_makdbl(SCM_REAL(x)-SCM_REALPART(y), SCM_IMAG(x)); - return scm_makdbl(SCM_REALPART(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0); - } - if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;} - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_addbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); -# endif - } -# ifndef RECKLESS - if (!(SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_difference); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_difference); -# endif -# endif - return scm_makdbl(SCM_INUM(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_difference); - if SCM_UNBNDP(y) { - x = scm_copybig(x, !SCM_BIGSIGN(x)); - return SCM_NUMDIGS(x) * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM) ? - scm_big2inum(x, SCM_NUMDIGS(x)) : x; - } - if SCM_INUMP(y) { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(y)); - return scm_addbig(&z, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_addbig(zdigs, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); -# endif - } - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return (SCM_NUMDIGS(x) < SCM_NUMDIGS(y)) ? - scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0x0100) : - scm_addbig(SCM_BDIGITS(y), SCM_NUMDIGS(y), SCM_BIGSIGN(y) ^ 0x0100, x, 0); - } - if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;} - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_difference); -# endif - { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_addbig(&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); -# endif - } - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_difference); - if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;} - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_difference); -# endif -#endif - x = SCM_INUM(x)-SCM_INUM(y); - checkx: - if SCM_FIXABLE(x) return SCM_MAKINUM(x); -#ifdef SCM_BIGDIG - return scm_long2big(x); -#else -# ifdef SCM_FLOATS - return scm_makdbl((double)x, 0.0); -# else - scm_num_overflow (s_difference); - return SCM_UNSPECIFIED; -# endif -#endif -} - - - - -SCM_PROC1 (s_product, "*", scm_tc7_asubr, scm_product); - -SCM -scm_product(x, y) - SCM x; - SCM y; -{ - if SCM_UNBNDP(y) { - if SCM_UNBNDP(x) return SCM_MAKINUM(1L); -#ifndef RECKLESS - if (!(SCM_NUMBERP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_product); -#endif - return x; - } -#ifdef SCM_FLOATS - if SCM_NINUMP(x) { - SCM t; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(x), badx); - if SCM_BIGP(x) { - if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;} - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return scm_mulbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y)); - SCM_ASRTGO(SCM_INEXP(y), bady); - bigreal: { - double bg = scm_big2dbl(x); - return scm_makdbl(bg*SCM_REALPART(y), SCM_CPLXP(y)?bg*SCM_IMAG(y):0.0); } - } - SCM_ASRTGO(SCM_INEXP(x), badx); -# else - SCM_ASRTGO(SCM_NIMP(x) && SCM_INEXP(x), badx); -# endif - if SCM_INUMP(y) {t = x; x = y; y = t; goto intreal;} -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;} -# ifndef RECKLESS - else if (!(SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_product); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_product); -# endif -# endif - if SCM_CPLXP(x) - if SCM_CPLXP(y) - return scm_makdbl(SCM_REAL(x)*SCM_REAL(y)-SCM_IMAG(x)*SCM_IMAG(y), - SCM_REAL(x)*SCM_IMAG(y)+SCM_IMAG(x)*SCM_REAL(y)); - else - return scm_makdbl(SCM_REAL(x)*SCM_REALPART(y), SCM_IMAG(x)*SCM_REALPART(y)); - return scm_makdbl(SCM_REALPART(x)*SCM_REALPART(y), - SCM_CPLXP(y)?SCM_REALPART(x)*SCM_IMAG(y):0.0); - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) { - intbig: if (SCM_INUM0==x) return x; if (SCM_MAKINUM(1L)==x) return y; - { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_mulbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(y) ? (x>0) : (x<0)); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_mulbig(zdigs, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(y) ? (x>0) : (x<0)); -# endif - } - } - SCM_ASRTGO(SCM_INEXP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady); -# endif - intreal: return scm_makdbl(SCM_INUM(x)*SCM_REALPART(y), SCM_CPLXP(y)?SCM_INUM(x)*SCM_IMAG(y):0.0); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM_ASRTGO(SCM_NIMP(x) && SCM_BIGP(x), badx); - if SCM_INUMP(y) {SCM t = x; x = y; y = t; goto intbig;} - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - return scm_mulbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y)); - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_product); -# endif - intbig: if (SCM_INUM0==x) return x; if (SCM_MAKINUM(1L)==x) return y; - { -# ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(x)); - return scm_mulbig(&z, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(y) ? (x>0) : (x<0)); -# else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(x), zdigs); - return scm_mulbig(zdigs, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(y) ? (x>0) : (x<0)); -# endif - } - } -# else - SCM_ASRTGO(SCM_INUMP(x), badx); - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_product); -# endif -#endif - { - long i, j, k; - i = SCM_INUM(x); - if (0==i) return x; - j = SCM_INUM(y); - k = i * j; - y = SCM_MAKINUM(k); - if (k != SCM_INUM(y) || k/i != j) -#ifdef SCM_BIGDIG - { int sgn = (i < 0) ^ (j < 0); -# ifndef SCM_DIGSTOOBIG - i = scm_pseudolong(i); - j = scm_pseudolong(j); - return scm_mulbig((SCM_BIGDIG *)&i, SCM_DIGSPERLONG, - (SCM_BIGDIG *)&j, SCM_DIGSPERLONG, sgn); -# else /* SCM_DIGSTOOBIG */ - SCM_BIGDIG idigs[SCM_DIGSPERLONG]; - SCM_BIGDIG jdigs[SCM_DIGSPERLONG]; - scm_longdigs(i, idigs); - scm_longdigs(j, jdigs); - return scm_mulbig(idigs, SCM_DIGSPERLONG, jdigs, SCM_DIGSPERLONG, sgn); -# endif - } -#else -# ifdef SCM_FLOATS - return scm_makdbl(((double)i)*((double)j), 0.0); -# else - scm_num_overflow (s_product); -# endif -#endif - return y; - } -} - - - -double -scm_num2dbl (a, why) - SCM a; - char * why; -{ - if (SCM_INUMP (a)) - return (double) SCM_INUM (a); -#ifdef SCM_FLOATS - SCM_ASSERT (SCM_NIMP (a), a, "wrong type argument", why); - if (SCM_REALP (a)) - return (SCM_REALPART (a)); -#endif -#ifdef SCM_BIGDIG - return scm_big2dbl (a); -#endif - SCM_ASSERT (0, a, "wrong type argument", why); - return SCM_UNSPECIFIED; -} - - -SCM_PROC1 (s_divide, "/", scm_tc7_asubr, scm_divide); - -SCM -scm_divide(x, y) - SCM x; - SCM y; -{ -#ifdef SCM_FLOATS - double d, r, i, a; - if SCM_NINUMP(x) { -# ifndef RECKLESS - if (!(SCM_NIMP(x))) - badx: scm_wta(x, (char *)SCM_ARG1, s_divide); -# endif - if SCM_UNBNDP(y) { -# ifdef SCM_BIGDIG - if SCM_BIGP(x) return scm_makdbl(1.0/scm_big2dbl(x), 0.0); -# endif - SCM_ASRTGO(SCM_INEXP(x), badx); - if SCM_REALP(x) return scm_makdbl(1.0/SCM_REALPART(x), 0.0); - r = SCM_REAL(x); i = SCM_IMAG(x); d = r*r+i*i; - return scm_makdbl(r/d, -i/d); - } -# ifdef SCM_BIGDIG - if SCM_BIGP(x) { - SCM z; - if SCM_INUMP(y) { - z = SCM_INUM(y); -#ifndef RECKLESS - if (!z) - scm_num_overflow (s_divide); -#endif - if (1==z) return x; - if (z < 0) z = -z; - if (z < SCM_BIGRAD) { - SCM w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0)); - return scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z) ? - scm_makdbl(scm_big2dbl(x)/SCM_INUM(y), 0.0) : scm_normbig(w); - } -# ifndef SCM_DIGSTOOBIG - z = scm_pseudolong(z); - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&z, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 3); -# else - { SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(z, zdigs); - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);} -# endif - return z ? z : scm_makdbl(scm_big2dbl(x)/SCM_INUM(y), 0.0); - } - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) { - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), 3); - return z ? z : scm_makdbl(scm_big2dbl(x)/scm_big2dbl(y), 0.0); - } - SCM_ASRTGO(SCM_INEXP(y), bady); - if SCM_REALP(y) return scm_makdbl(scm_big2dbl(x)/SCM_REALPART(y), 0.0); - a = scm_big2dbl(x); - goto complex_div; - } -# endif - SCM_ASRTGO(SCM_INEXP(x), badx); - if SCM_INUMP(y) {d = SCM_INUM(y); goto basic_div;} -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) {d = scm_big2dbl(y); goto basic_div;} - SCM_ASRTGO(SCM_INEXP(y), bady); -# else - SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady); -# endif - if SCM_REALP(y) { - d = SCM_REALPART(y); - basic_div: return scm_makdbl(SCM_REALPART(x)/d, SCM_CPLXP(x)?SCM_IMAG(x)/d:0.0); - } - a = SCM_REALPART(x); - if SCM_REALP(x) goto complex_div; - r = SCM_REAL(y); i = SCM_IMAG(y); d = r*r+i*i; - return scm_makdbl((a*r+SCM_IMAG(x)*i)/d, (SCM_IMAG(x)*r-a*i)/d); - } - if SCM_UNBNDP(y) { - if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x; - return scm_makdbl(1.0/((double)SCM_INUM(x)), 0.0); - } - if SCM_NINUMP(y) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(y), bady); - if SCM_BIGP(y) return scm_makdbl(SCM_INUM(x)/scm_big2dbl(y), 0.0); -# ifndef RECKLESS - if (!(SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_divide); -# endif -# else -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_INEXP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_divide); -# endif -# endif - if (SCM_REALP(y)) - return scm_makdbl(SCM_INUM(x)/SCM_REALPART(y), 0.0); - a = SCM_INUM(x); - complex_div: - r = SCM_REAL(y); i = SCM_IMAG(y); d = r*r+i*i; - return scm_makdbl((a*r)/d, (-a*i)/d); - } -#else -# ifdef SCM_BIGDIG - if SCM_NINUMP(x) { - SCM z; - SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_divide); - if SCM_UNBNDP(y) goto ov; - if SCM_INUMP(y) { - z = SCM_INUM(y); - if (!z) goto ov; - if (1==z) return x; - if (z < 0) z = -z; - if (z < SCM_BIGRAD) { - SCM w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0)); - if (scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z)) goto ov; - return w; - } -# ifndef SCM_DIGSTOOBIG - z = scm_pseudolong(z); - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), &z, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 3); -# else - { SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(z, zdigs); - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG, - SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);} -# endif - } else { - SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady); - z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y), - SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), 3); - } - if (!z) goto ov; - return z; - } - if SCM_UNBNDP(y) { - if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x; - goto ov; - } - if SCM_NINUMP(y) { -# ifndef RECKLESS - if (!(SCM_NIMP(y) && SCM_BIGP(y))) - bady: scm_wta(y, (char *)SCM_ARG2, s_divide); -# endif - goto ov; - } -# else - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_divide); - if SCM_UNBNDP(y) { - if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x; - goto ov; - } - SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_divide); -# endif -#endif - { - long z = SCM_INUM(y); - if ((0==z) || SCM_INUM(x)%z) goto ov; - z = SCM_INUM(x)/z; - if SCM_FIXABLE(z) return SCM_MAKINUM(z); -#ifdef SCM_BIGDIG - return scm_long2big(z); -#endif -#ifdef SCM_FLOATS - ov: return scm_makdbl(((double)SCM_INUM(x))/((double)SCM_INUM(y)), 0.0); -#else - ov: scm_num_overflow (s_divide); - return SCM_UNSPECIFIED; -#endif - } -} - - - - -#ifdef SCM_FLOATS -SCM_PROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh); - -double -scm_asinh(x) - double x; -{ - return log(x+sqrt(x*x+1)); -} - - - - -SCM_PROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh); - -double -scm_acosh(x) - double x; -{ - return log(x+sqrt(x*x-1)); -} - - - - -SCM_PROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh); - -double -scm_atanh(x) - double x; -{ - return 0.5*log((1+x)/(1-x)); -} - - - - -SCM_PROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate); - -double -scm_truncate(x) - double x; -{ - if (x < 0.0) return -floor(-x); - return floor(x); -} - - - -SCM_PROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round); - -double -scm_round(x) - double x; -{ - double plus_half = x + 0.5; - double result = floor(plus_half); - /* Adjust so that the scm_round is towards even. */ - return (plus_half == result && plus_half / 2 != floor(plus_half / 2)) - ? result - 1 : result; -} - - - -SCM_PROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact); - -double -scm_exact_to_inexact(z) - double z; -{ - return z; -} - - -SCM_PROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor); -SCM_PROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil); -SCM_PROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)())sqrt); -SCM_PROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)())fabs); -SCM_PROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)())exp); -SCM_PROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)())log); -SCM_PROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)())sin); -SCM_PROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)())cos); -SCM_PROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)())tan); -SCM_PROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)())asin); -SCM_PROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)())acos); -SCM_PROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)())atan); -SCM_PROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)())sinh); -SCM_PROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)())cosh); -SCM_PROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)())tanh); - -struct dpair {double x, y;}; - -static void scm_two_doubles SCM_P ((SCM z1, SCM z2, char *sstring, struct dpair *xy)); - -static void -scm_two_doubles(z1, z2, sstring, xy) - SCM z1, z2; - char *sstring; - struct dpair *xy; -{ - if SCM_INUMP(z1) xy->x = SCM_INUM(z1); - else { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z1), badz1); - if SCM_BIGP(z1) xy->x = scm_big2dbl(z1); - else { -# ifndef RECKLESS - if (!(SCM_REALP(z1))) - badz1: scm_wta(z1, (char *)SCM_ARG1, sstring); -# endif - xy->x = SCM_REALPART(z1);} -# else - {SCM_ASSERT(SCM_NIMP(z1) && SCM_REALP(z1), z1, SCM_ARG1, sstring); - xy->x = SCM_REALPART(z1);} -# endif - } - if SCM_INUMP(z2) xy->y = SCM_INUM(z2); - else { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z2), badz2); - if SCM_BIGP(z2) xy->y = scm_big2dbl(z2); - else { -# ifndef RECKLESS - if (!(SCM_REALP(z2))) - badz2: scm_wta(z2, (char *)SCM_ARG2, sstring); -# endif - xy->y = SCM_REALPART(z2);} -# else - {SCM_ASSERT(SCM_NIMP(z2) && SCM_REALP(z2), z2, SCM_ARG2, sstring); - xy->y = SCM_REALPART(z2);} -# endif - } -} - - - - -SCM_PROC(s_sys_expt, "$expt", 2, 0, 0, scm_sys_expt); - -SCM -scm_sys_expt(z1, z2) - SCM z1; - SCM z2; -{ - struct dpair xy; - scm_two_doubles(z1, z2, s_sys_expt, &xy); - return scm_makdbl(pow(xy.x, xy.y), 0.0); -} - - - -SCM_PROC(s_sys_atan2, "$atan2", 2, 0, 0, scm_sys_atan2); - -SCM -scm_sys_atan2(z1, z2) - SCM z1; - SCM z2; -{ - struct dpair xy; - scm_two_doubles(z1, z2, s_sys_atan2, &xy); - return scm_makdbl(atan2(xy.x, xy.y), 0.0); -} - - - -SCM_PROC(s_make_rectangular, "make-rectangular", 2, 0, 0, scm_make_rectangular); - -SCM -scm_make_rectangular(z1, z2) - SCM z1; - SCM z2; -{ - struct dpair xy; - scm_two_doubles(z1, z2, s_make_rectangular, &xy); - return scm_makdbl(xy.x, xy.y); -} - - - -SCM_PROC(s_make_polar, "make-polar", 2, 0, 0, scm_make_polar); - -SCM -scm_make_polar(z1, z2) - SCM z1; - SCM z2; -{ - struct dpair xy; - scm_two_doubles(z1, z2, s_make_polar, &xy); - return scm_makdbl(xy.x*cos(xy.y), xy.x*sin(xy.y)); -} - - - - -SCM_PROC(s_real_part, "real-part", 1, 0, 0, scm_real_part); - -SCM -scm_real_part(z) - SCM z; -{ - if SCM_NINUMP(z) { -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) return z; -# ifndef RECKLESS - if (!(SCM_INEXP(z))) - badz: scm_wta(z, (char *)SCM_ARG1, s_real_part); -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_real_part); -# endif - if SCM_CPLXP(z) return scm_makdbl(SCM_REAL(z), 0.0); - } - return z; -} - - - -SCM_PROC(s_imag_part, "imag-part", 1, 0, 0, scm_imag_part); - -SCM -scm_imag_part(z) - SCM z; -{ - if SCM_INUMP(z) return SCM_INUM0; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) return SCM_INUM0; -# ifndef RECKLESS - if (!(SCM_INEXP(z))) - badz: scm_wta(z, (char *)SCM_ARG1, s_imag_part); -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_imag_part); -# endif - if SCM_CPLXP(z) return scm_makdbl(SCM_IMAG(z), 0.0); - return scm_flo0; -} - - - -SCM_PROC(s_magnitude, "magnitude", 1, 0, 0, scm_magnitude); - -SCM -scm_magnitude(z) - SCM z; -{ - if SCM_INUMP(z) return scm_abs(z); -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) return scm_abs(z); -# ifndef RECKLESS - if (!(SCM_INEXP(z))) - badz: scm_wta(z, (char *)SCM_ARG1, s_magnitude); -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_magnitude); -# endif - if SCM_CPLXP(z) - { - double i = SCM_IMAG(z), r = SCM_REAL(z); - return scm_makdbl(sqrt(i*i+r*r), 0.0); - } - return scm_makdbl(fabs(SCM_REALPART(z)), 0.0); -} - - - - -SCM_PROC(s_angle, "angle", 1, 0, 0, scm_angle); - -SCM -scm_angle(z) - SCM z; -{ - double x, y = 0.0; - if SCM_INUMP(z) {x = (z>=SCM_INUM0) ? 1.0 : -1.0; goto do_angle;} -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) {x = (SCM_TYP16(z)==scm_tc16_bigpos) ? 1.0 : -1.0; goto do_angle;} -# ifndef RECKLESS - if (!(SCM_INEXP(z))) { - badz: scm_wta(z, (char *)SCM_ARG1, s_angle);} -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_angle); -# endif - if (SCM_REALP(z)) - { - x = SCM_REALPART(z); - goto do_angle; - } - x = SCM_REAL(z); y = SCM_IMAG(z); - do_angle: - return scm_makdbl(atan2(y, x), 0.0); -} - - -SCM_PROC(s_inexact_to_exact, "inexact->exact", 1, 0, 0, scm_inexact_to_exact); - -SCM -scm_inexact_to_exact(z) - SCM z; -{ - if SCM_INUMP(z) return z; -# ifdef SCM_BIGDIG - SCM_ASRTGO(SCM_NIMP(z), badz); - if SCM_BIGP(z) return z; -# ifndef RECKLESS - if (!(SCM_REALP(z))) - badz: scm_wta(z, (char *)SCM_ARG1, s_inexact_to_exact); -# endif -# else - SCM_ASSERT(SCM_NIMP(z) && SCM_REALP(z), z, SCM_ARG1, s_inexact_to_exact); -# endif -# ifdef SCM_BIGDIG - { - double u = floor(SCM_REALPART(z)+0.5); - if ((u <= SCM_MOST_POSITIVE_FIXNUM) && (-u <= -SCM_MOST_NEGATIVE_FIXNUM)) { - /* Negation is a workaround for HP700 cc bug */ - SCM ans = SCM_MAKINUM((long)u); - if (SCM_INUM(ans)==(long)u) return ans; - } - SCM_ASRTGO(!IS_INF(u), badz); /* problem? */ - return scm_dbl2big(u); - } -# else - return SCM_MAKINUM((long)floor(SCM_REALPART(z)+0.5)); -# endif -} - - - -#else /* ~SCM_FLOATS */ -SCM_PROC(s_trunc, "truncate", 1, 0, 0, scm_trunc); - -SCM -scm_trunc(x) - SCM x; -{ - SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_truncate); - return x; -} - - - -#endif /* SCM_FLOATS */ - -#ifdef SCM_BIGDIG -# ifdef SCM_FLOATS -/* d must be integer */ - -SCM -scm_dbl2big(d) - double d; -{ - scm_sizet i = 0; - long c; - SCM_BIGDIG *digits; - SCM ans; - double u = (d < 0)?-d:d; - while (0 != floor(u)) {u /= SCM_BIGRAD;i++;} - ans = scm_mkbig(i, d < 0); - digits = SCM_BDIGITS(ans); - while (i--) { - u *= SCM_BIGRAD; - c = floor(u); - u -= c; - digits[i] = c; - } -#ifndef RECKLESS - if (u != 0) - scm_num_overflow ("dbl2big"); -#endif - return ans; -} - - - - -double -scm_big2dbl(b) - SCM b; -{ - double ans = 0.0; - scm_sizet i = SCM_NUMDIGS(b); - SCM_BIGDIG *digits = SCM_BDIGITS(b); - while (i--) ans = digits[i] + SCM_BIGRAD*ans; - if (scm_tc16_bigneg==SCM_TYP16(b)) return -ans; - return ans; -} -# endif -#endif - - -SCM -scm_long2num(sl) - long sl; -{ - if (!SCM_FIXABLE(sl)) { -#ifdef SCM_BIGDIG - return scm_long2big(sl); -#else -# ifdef SCM_FLOATS - return scm_makdbl((double) sl, 0.0); -# else - return SCM_BOOL_F; -# endif -#endif - } - return SCM_MAKINUM(sl); -} - - -#ifdef LONGLONGS - -SCM -scm_long_long2num(sl) - long_long sl; -{ - if (!SCM_FIXABLE(sl)) { -#ifdef SCM_BIGDIG - return scm_long_long2big(sl); -#else -# ifdef SCM_FLOATS - return scm_makdbl((double) sl, 0.0); -# else - return SCM_BOOL_F; -# endif -#endif - } - return SCM_MAKINUM(sl); -} -#endif - - - -SCM -scm_ulong2num(sl) - unsigned long sl; -{ - if (!SCM_POSFIXABLE(sl)) { -#ifdef SCM_BIGDIG - return scm_ulong2big(sl); -#else -# ifdef SCM_FLOATS - return scm_makdbl((double) sl, 0.0); -# else - return SCM_BOOL_F; -# endif -#endif - } - return SCM_MAKINUM(sl); -} - - -long -scm_num2long(num, pos, s_caller) - SCM num; - char *pos; - char *s_caller; -{ - long res; - if (SCM_INUMP(num)) - { - res = SCM_INUM(num); - return res; - } - SCM_ASRTGO(SCM_NIMP(num), errout); -#ifdef SCM_FLOATS - if (SCM_REALP(num)) - { - double u = SCM_REALPART(num); - res = u; - if ((double)res == u) - { - return res; - } - } -#endif -#ifdef SCM_BIGDIG - if (SCM_BIGP(num)) { - long oldres; - scm_sizet l; - res = 0; - oldres = 0; - for(l = SCM_NUMDIGS(num);l--;) - { - res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l]; - if (res < oldres) - goto errout; - oldres = res; - } - if (SCM_TYP16 (num) == scm_tc16_bigpos) - return res; - else - return -res; - } -#endif - errout: scm_wta(num, pos, s_caller); - return SCM_UNSPECIFIED; -} - - - - - -long -num2long(num, pos, s_caller) - SCM num; - char *pos; - char *s_caller; -{ - long res; - if SCM_INUMP(num) { - res = SCM_INUM((long)num); - return res; - } - SCM_ASRTGO(SCM_NIMP(num), errout); -#ifdef SCM_FLOATS - if SCM_REALP(num) { - double u = SCM_REALPART(num); - if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u) - && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3))) { - res = u; - return res; - } - } -#endif -#ifdef SCM_BIGDIG - if SCM_BIGP(num) { - scm_sizet l = SCM_NUMDIGS(num); - SCM_ASRTGO(SCM_DIGSPERLONG >= l, errout); - res = 0; - for(;l--;) res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l]; - return res; - } -#endif - errout: scm_wta(num, pos, s_caller); - return SCM_UNSPECIFIED; -} - - -#ifdef LONGLONGS - -long_long -scm_num2long_long(num, pos, s_caller) - SCM num; - char *pos; - char *s_caller; -{ - long_long res; - if SCM_INUMP(num) { - res = SCM_INUM((long_long)num); - return res; - } - SCM_ASRTGO(SCM_NIMP(num), errout); -#ifdef SCM_FLOATS - if SCM_REALP(num) { - double u = SCM_REALPART(num); - if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u) - && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3))) { - res = u; - return res; - } - } -#endif -#ifdef SCM_BIGDIG - if SCM_BIGP(num) { - scm_sizet l = SCM_NUMDIGS(num); - SCM_ASRTGO(SCM_DIGSPERLONGLONG >= l, errout); - res = 0; - for(;l--;) res = SCM_LONGLONGBIGUP(res) + SCM_BDIGITS(num)[l]; - return res; - } -#endif - errout: scm_wta(num, pos, s_caller); - return SCM_UNSPECIFIED; -} -#endif - - - -unsigned long -scm_num2ulong(num, pos, s_caller) - SCM num; - char *pos; - char *s_caller; -{ - unsigned long res; - if (SCM_INUMP(num)) - { - res = SCM_INUM((unsigned long)num); - return res; - } - SCM_ASRTGO(SCM_NIMP(num), errout); -#ifdef SCM_FLOATS - if (SCM_REALP(num)) - { - double u = SCM_REALPART(num); - if ((0 <= u) && (u <= (unsigned long)~0L)) - { - res = u; - return res; - } - } -#endif -#ifdef SCM_BIGDIG - if (SCM_BIGP(num)) { - unsigned long oldres; - scm_sizet l; - res = 0; - oldres = 0; - for(l = SCM_NUMDIGS(num);l--;) - { - res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l]; - if (res < oldres) - goto errout; - oldres = res; - } - return res; - } -#endif - errout: scm_wta(num, pos, s_caller); - return SCM_UNSPECIFIED; -} - - -#ifdef SCM_FLOATS -# ifndef DBL_DIG -static void add1 SCM_P ((double f, double *fsum)); -static void add1(f, fsum) - double f, *fsum; -{ - *fsum = f + 1.0; -} -# endif -#endif - - - -void -scm_init_numbers () -{ -#ifdef SCM_FLOATS - SCM_NEWCELL(scm_flo0); -# ifdef SCM_SINGLES - SCM_SETCAR (scm_flo0, scm_tc_flo); - SCM_FLO(scm_flo0) = 0.0; -# else - SCM_SETCDR (scm_flo0, (SCM)scm_must_malloc(1L*sizeof(double), "real")); - SCM_REAL(scm_flo0) = 0.0; - SCM_SETCAR (scm_flo0, scm_tc_dblr); -# endif -# ifdef DBL_DIG - scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG; -# else - { /* determine floating point precision */ - double f = 0.1; - double fsum = 1.0+f; - while (fsum != 1.0) { - f /= 10.0; - if (++scm_dblprec > 20) break; - add1(f, &fsum); - } - scm_dblprec = scm_dblprec-1; - } -# endif /* DBL_DIG */ -#endif -#include "numbers.x" -} - diff --git a/libguile/numbers.h b/libguile/numbers.h deleted file mode 100644 index d34e09d9c..000000000 --- a/libguile/numbers.h +++ /dev/null @@ -1,323 +0,0 @@ -/* classes: h_files */ - -#ifndef NUMBERSH -#define NUMBERSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - -/* Immediate Numbers - * - * Inums are exact integer data that fits within an SCM word. - * - * SCM_INUMP applies only to values known to be Scheme objects. - * In particular, SCM_INUMP (SCM_CAR (x)) is valid only if x is known - * to be a SCM_CONSP. If x is only known to be a SCM_NIMP, - * SCM_INUMP (SCM_CAR (x)) can give wrong answers. - */ - -#define SCM_INUMP(x) (2 & (int)(x)) -#define SCM_NINUMP(x) (!SCM_INUMP(x)) - -#ifdef __TURBOC__ -/* shifts of more than one are done by a library call, single shifts are - * performed in registers - */ -# define SCM_MAKINUM(x) ((((x)<<1)<<1)+2L) -#else -# define SCM_MAKINUM(x) (((x)<<2)+2L) -#endif /* def __TURBOC__ */ - - -/* SCM_SRS is signed right shift */ -/* Turbo C++ v1.0 has a bug with right shifts of signed longs! - * It is believed to be fixed in Turbo C++ v1.01 - */ -#if (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295) -# define SCM_SRS(x, y) ((x)>>y) -# ifdef __TURBOC__ -# define SCM_INUM(x) (((x)>>1)>>1) -# else -# define SCM_INUM(x) SCM_SRS(x, 2) -# endif /* def __TURBOC__ */ -#else -# define SCM_SRS(x, y) (((x)<0) ? ~((~(x))>>y) : (x)>>y) -# define SCM_INUM(x) SCM_SRS(x, 2) -#endif /* (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295) */ - - -/* A name for 0. - */ -#define SCM_INUM0 ((SCM) 2) - - - -/* SCM_FIXABLE is non-0 if its long argument can be encoded in an SCM_INUM. - */ -#define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM) -#define SCM_NEGFIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM) -#define SCM_UNEGFIXABLE(n) ((n) <= -SCM_MOST_NEGATIVE_FIXNUM) -#define SCM_FIXABLE(n) (SCM_POSFIXABLE(n) && SCM_NEGFIXABLE(n)) - -/* SCM_INTBUFLEN is the maximum number of characters neccessary for the - * printed or scm_string representation of an exact immediate. - */ - -#ifndef SCM_CHAR_BIT -# define SCM_CHAR_BIT 8 -#endif /* ndef SCM_CHAR_BIT */ -#ifndef SCM_LONG_BIT -# define SCM_LONG_BIT (SCM_CHAR_BIT*sizeof(long)/sizeof(char)) -#endif /* ndef SCM_LONG_BIT */ -#define SCM_INTBUFLEN (5+SCM_LONG_BIT) - -/* SCM_FLOBUFLEN is the maximum number of characters neccessary for the - * printed or scm_string representation of an inexact number. - */ - -#define SCM_FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10) - - - - -/* Numbers - */ - -#define SCM_INEXP(x) (SCM_TYP16(x)==scm_tc16_flo) -#define SCM_CPLXP(x) (SCM_CAR(x)==scm_tc_dblc) -#define SCM_REAL(x) (*(((scm_dbl *) (SCM2PTR(x)))->real)) -#define SCM_IMAG(x) (*((double *)(SCM_CHARS(x)+sizeof(double)))) -/* ((&SCM_REAL(x))[1]) */ - - -#ifdef SCM_SINGLES -#define SCM_REALP(x) ((~SCM_REAL_PART & SCM_CAR(x))==scm_tc_flo) -#define SCM_SINGP(x) (SCM_CAR(x)==scm_tc_flo) -#define SCM_FLO(x) (((scm_flo *)(SCM2PTR(x)))->num) -#define SCM_REALPART(x) (SCM_SINGP(x)?0.0+SCM_FLO(x):SCM_REAL(x)) -#else /* SCM_SINGLES */ -#define SCM_REALP(x) (SCM_CAR(x)==scm_tc_dblr) -#define SCM_REALPART SCM_REAL -#endif /* SCM_SINGLES */ - - -/* Define SCM_BIGDIG to an integer type whose size is smaller than long if - * you want bignums. SCM_BIGRAD is one greater than the biggest SCM_BIGDIG. - * - * Define SCM_DIGSTOOBIG if the digits equivalent to a long won't fit in a long. - */ -#ifdef BIGNUMS -# ifdef _UNICOS -# define SCM_DIGSTOOBIG -# if (1L << 31) <= SCM_USHRT_MAX -# define SCM_BIGDIG unsigned short -# else -# define SCM_BIGDIG unsigned int -# endif /* (1L << 31) <= USHRT_MAX */ -# define SCM_BITSPERDIG 32 -# else -# define SCM_BIGDIG unsigned short -# define SCM_BITSPERDIG (sizeof(SCM_BIGDIG)*SCM_CHAR_BIT) -# endif /* def _UNICOS */ - -# define SCM_BIGRAD (1L << SCM_BITSPERDIG) -# define SCM_DIGSPERLONG ((scm_sizet)((sizeof(long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG)) -# define SCM_DIGSPERLONGLONG ((scm_sizet)((sizeof(long long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG)) -# define SCM_BIGUP(x) ((unsigned long)(x) << SCM_BITSPERDIG) -# define SCM_LONGLONGBIGUP(x) ((ulong_long)(x) << SCM_BITSPERDIG) -# define SCM_BIGDN(x) ((x) >> SCM_BITSPERDIG) -# define SCM_BIGLO(x) ((x) & (SCM_BIGRAD-1)) -#endif /* def BIGNUMS */ - -#ifndef SCM_BIGDIG -/* Definition is not really used but helps various function - * prototypes to compile with conditionalization. - */ -# define SCM_BIGDIG unsigned short -# define SCM_NO_BIGDIG -# ifndef SCM_FLOATS -# define SCM_INUMS_ONLY -# endif /* ndef SCM_FLOATS */ -#endif /* ndef SCM_BIGDIG */ - -#ifdef SCM_FLOATS -#define SCM_NUMBERP(x) (SCM_INUMP(x) || (SCM_NIMP(x) && SCM_NUMP(x))) -#else -#ifdef SCM_BIGDIG -#define SCM_NUMBERP(x) (SCM_INUMP(x) || (SCM_NIMP(x) && SCM_NUMP(x))) -#else -#define SCM_NUMBERP SCM_INUMP -#endif -#endif -#define SCM_NUMP(x) ((0xfcff & (int)SCM_CAR(x))==scm_tc7_smob) -#define SCM_BIGP(x) (SCM_TYP16S(x)==scm_tc16_bigpos) -#define SCM_BIGSIGN(x) (0x0100 & (int)SCM_CAR(x)) -#define SCM_BDIGITS(x) ((SCM_BIGDIG *)(SCM_CDR(x))) -#define SCM_NUMDIGS(x) ((scm_sizet)(SCM_CAR(x)>>16)) -#define SCM_SETNUMDIGS(x, v, t) SCM_SETCAR(x, (((v)+0L)<<16)+(t)) - - -#ifdef SCM_FLOATS -typedef struct scm_dblproc -{ - char *scm_string; - double (*cproc) (); -} scm_dblproc; - -#ifdef SCM_SINGLES -typedef struct scm_flo -{ - SCM type; - float num; -} scm_flo; -#endif - -typedef struct scm_dbl -{ - SCM type; - double *real; -} scm_dbl; -#endif - - - - - -extern SCM scm_exact_p SCM_P ((SCM x)); -extern SCM scm_odd_p SCM_P ((SCM n)); -extern SCM scm_even_p SCM_P ((SCM n)); -extern SCM scm_abs SCM_P ((SCM x)); -extern SCM scm_quotient SCM_P ((SCM x, SCM y)); -extern SCM scm_remainder SCM_P ((SCM x, SCM y)); -extern SCM scm_modulo SCM_P ((SCM x, SCM y)); -extern SCM scm_gcd SCM_P ((SCM x, SCM y)); -extern SCM scm_lcm SCM_P ((SCM n1, SCM n2)); -extern SCM scm_logand SCM_P ((SCM n1, SCM n2)); -extern SCM scm_logior SCM_P ((SCM n1, SCM n2)); -extern SCM scm_logxor SCM_P ((SCM n1, SCM n2)); -extern SCM scm_logtest SCM_P ((SCM n1, SCM n2)); -extern SCM scm_logbit_p SCM_P ((SCM n1, SCM n2)); -extern SCM scm_lognot SCM_P ((SCM n)); -extern SCM scm_integer_expt SCM_P ((SCM z1, SCM z2)); -extern SCM scm_ash SCM_P ((SCM n, SCM cnt)); -extern SCM scm_bit_extract SCM_P ((SCM n, SCM start, SCM end)); -extern SCM scm_logcount SCM_P ((SCM n)); -extern SCM scm_integer_length SCM_P ((SCM n)); -extern SCM scm_mkbig SCM_P ((scm_sizet nlen, int sign)); -extern SCM scm_big2inum SCM_P ((SCM b, scm_sizet l)); -extern SCM scm_adjbig SCM_P ((SCM b, scm_sizet nlen)); -extern SCM scm_normbig SCM_P ((SCM b)); -extern SCM scm_copybig SCM_P ((SCM b, int sign)); -extern SCM scm_long2big SCM_P ((long n)); -extern SCM scm_long_long2big SCM_P ((long_long n)); -extern SCM scm_2ulong2big SCM_P ((unsigned long * np)); -extern SCM scm_ulong2big SCM_P ((unsigned long n)); -extern int scm_bigcomp SCM_P ((SCM x, SCM y)); -extern long scm_pseudolong SCM_P ((long x)); -extern void scm_longdigs SCM_P ((long x, SCM_BIGDIG digs[])); -extern SCM scm_addbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny)); -extern SCM scm_mulbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn)); -extern unsigned int scm_divbigdig SCM_P ((SCM_BIGDIG *ds, scm_sizet h, SCM_BIGDIG div)); -extern SCM scm_divbigint SCM_P ((SCM x, long z, int sgn, int mode)); -extern SCM scm_divbigbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes)); -extern scm_sizet scm_iint2str SCM_P ((long num, int rad, char *p)); -extern SCM scm_number_to_string SCM_P ((SCM x, SCM radix)); -extern int scm_floprint SCM_P ((SCM sexp, SCM port, scm_print_state *pstate)); -extern int scm_bigprint SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); -extern SCM scm_istr2int SCM_P ((char *str, long len, long radix)); -extern SCM scm_istr2flo SCM_P ((char *str, long len, long radix)); -extern SCM scm_istring2number SCM_P ((char *str, long len, long radix)); -extern SCM scm_string_to_number SCM_P ((SCM str, SCM radix)); -extern SCM scm_makdbl SCM_P ((double x, double y)); -extern SCM scm_bigequal SCM_P ((SCM x, SCM y)); -extern SCM scm_floequal SCM_P ((SCM x, SCM y)); -extern SCM scm_number_p SCM_P ((SCM x)); -extern SCM scm_real_p SCM_P ((SCM x)); -extern SCM scm_integer_p SCM_P ((SCM x)); -extern SCM scm_inexact_p SCM_P ((SCM x)); -extern SCM scm_num_eq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_less_p SCM_P ((SCM x, SCM y)); -extern SCM scm_gr_p SCM_P ((SCM x, SCM y)); -extern SCM scm_leq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_geq_p SCM_P ((SCM x, SCM y)); -extern SCM scm_zero_p SCM_P ((SCM z)); -extern SCM scm_positive_p SCM_P ((SCM x)); -extern SCM scm_negative_p SCM_P ((SCM x)); -extern SCM scm_max SCM_P ((SCM x, SCM y)); -extern SCM scm_min SCM_P ((SCM x, SCM y)); -extern SCM scm_sum SCM_P ((SCM x, SCM y)); -extern SCM scm_difference SCM_P ((SCM x, SCM y)); -extern SCM scm_product SCM_P ((SCM x, SCM y)); -extern double scm_num2dbl SCM_P ((SCM a, char * why)); -extern SCM scm_divide SCM_P ((SCM x, SCM y)); -extern double scm_asinh SCM_P ((double x)); -extern double scm_acosh SCM_P ((double x)); -extern double scm_atanh SCM_P ((double x)); -extern double scm_truncate SCM_P ((double x)); -extern double scm_round SCM_P ((double x)); -extern double scm_exact_to_inexact SCM_P ((double z)); -extern SCM scm_sys_expt SCM_P ((SCM z1, SCM z2)); -extern SCM scm_sys_atan2 SCM_P ((SCM z1, SCM z2)); -extern SCM scm_make_rectangular SCM_P ((SCM z1, SCM z2)); -extern SCM scm_make_polar SCM_P ((SCM z1, SCM z2)); -extern SCM scm_real_part SCM_P ((SCM z)); -extern SCM scm_imag_part SCM_P ((SCM z)); -extern SCM scm_magnitude SCM_P ((SCM z)); -extern SCM scm_angle SCM_P ((SCM z)); -extern SCM scm_inexact_to_exact SCM_P ((SCM z)); -extern SCM scm_trunc SCM_P ((SCM x)); -extern SCM scm_dbl2big SCM_P ((double d)); -extern double scm_big2dbl SCM_P ((SCM b)); -extern SCM scm_long2num SCM_P ((long sl)); -extern SCM scm_long_long2num SCM_P ((long_long sl)); -extern SCM scm_ulong2num SCM_P ((unsigned long sl)); -extern long scm_num2long SCM_P ((SCM num, char *pos, char *s_caller)); -extern long num2long SCM_P ((SCM num, char *pos, char *s_caller)); -extern long_long scm_num2long_long SCM_P ((SCM num, char *pos, char *s_caller)); -extern unsigned long scm_num2ulong SCM_P ((SCM num, char *pos, char *s_caller)); -extern void scm_init_numbers SCM_P ((void)); - -#endif /* NUMBERSH */ diff --git a/libguile/objprop.c b/libguile/objprop.c deleted file mode 100644 index f644a6694..000000000 --- a/libguile/objprop.c +++ /dev/null @@ -1,120 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "hashtab.h" -#include "alist.h" -#include "weaks.h" - -#include "objprop.h" - - -/* {Object Properties} - */ - -SCM_PROC(s_object_properties, "object-properties", 1, 0, 0, scm_object_properties); - -SCM -scm_object_properties (obj) - SCM obj; -{ - return scm_hashq_ref (scm_object_whash, obj, SCM_EOL); -} - - -SCM_PROC(s_set_object_properties_x, "set-object-properties!", 2, 0, 0, scm_set_object_properties_x); - -SCM -scm_set_object_properties_x (obj, plist) - SCM obj; - SCM plist; -{ - SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, plist); - SCM_SETCDR (handle, plist); - return plist; -} - -SCM_PROC(s_object_property, "object-property", 2, 0, 0, scm_object_property); - -SCM -scm_object_property (obj, key) - SCM obj; - SCM key; -{ - SCM assoc; - assoc = scm_assq (key, SCM_CDR (scm_object_properties (obj))); - return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F); -} - -SCM_PROC(s_set_object_property_x, "set-object-property!", 3, 0, 0, scm_set_object_property_x); - -SCM -scm_set_object_property_x (obj, key, val) - SCM obj; - SCM key; - SCM val; -{ - SCM h; - SCM assoc; - h = scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL); - SCM_DEFER_INTS; - assoc = scm_assoc (key, SCM_CDR (h)); - if (SCM_NIMP (assoc)) - SCM_SETCDR (assoc, val); - else - { - assoc = scm_acons (key, val, SCM_CDR (h)); - SCM_SETCDR (h, assoc); - } - SCM_ALLOW_INTS; - return val; -} - - -void -scm_init_objprop () -{ - scm_object_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (511)); -#include "objprop.x" -} - diff --git a/libguile/objprop.h b/libguile/objprop.h deleted file mode 100644 index 89a662346..000000000 --- a/libguile/objprop.h +++ /dev/null @@ -1,62 +0,0 @@ -/* classes: h_files */ - -#ifndef OBJPROPH -#define OBJPROPH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "libguile/__scm.h" - - - - - - - -extern SCM scm_object_properties SCM_P ((SCM obj)); -extern SCM scm_set_object_properties_x SCM_P ((SCM obj, SCM plist)); -extern SCM scm_object_property SCM_P ((SCM obj, SCM key)); -extern SCM scm_set_object_property_x SCM_P ((SCM obj, SCM key, SCM val)); -extern void scm_init_objprop SCM_P ((void)); - -#endif /* OBJPROPH */ diff --git a/libguile/options.c b/libguile/options.c deleted file mode 100644 index ade12e2ee..000000000 --- a/libguile/options.c +++ /dev/null @@ -1,227 +0,0 @@ -/* Copyright (C) 1995,1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "options.h" - - -/* {Run-time options} - * - * This is the basic interface for low-level configuration of the - * Guile library. It is used for configuring the reader, evaluator, - * printer and debugger. - * - * Motivation: - * - * 1. Altering option settings can have side effects. - * 2. Option values can be stored in native format. - * (Important for efficiency in, e. g., the evaluator.) - * 3. Doesn't use up name space. - * 4. Options can be naturally grouped => ease of use. - */ - -/* scm_options is the core of all options interface procedures. - * - * Some definitions: - * - * Run time options in Guile are arranged in groups. Each group - * affects a certain aspect of the behaviour of the library. - * - * An "options interface procedure" manages one group of options. It - * can be used to check or set options, or to get documentation for - * all options of a group. The options interface procedure is not - * intended to be called directly by the user. The user should - * instead call - * - * (<group>-options) - * (<group>-options 'help) - * (<group>-options 'full) - * - * to display current option settings (The second version also - * displays documentation. The third version also displays - * information about programmer's options.), and - * - * (<group>-enable '<option-symbol>) - * (<group>-disable '<option-symbol>) - * (<group>-set! <option-symbol> <value>) - * (<group>-options <option setting>) - * - * to alter the state of an option (The last version sets all - * options according to <option setting>.) where <group> is the name - * of the option group. - * - * An "option setting" represents the state of all low-level options - * managed by one options interface procedure. It is a list of - * single symbols and symbols followed by a value. - * - * For boolean options, the presence of the symbol of that option in - * the option setting indicates a true value. If the symbol isn't a - * member of the option setting this represents a false value. - * - * Other options are represented by a symbol followed by the value. - * - * If scm_options is called without arguments, the current option - * setting is returned. If the argument is an option setting, options - * are altered and the old setting is returned. If the argument isn't - * a list, a list of sublists is returned, where each sublist contains - * option name, value and documentation string. - */ - -SCM_SYMBOL (scm_yes_sym, "yes"); -SCM_SYMBOL (scm_no_sym, "no"); - - -SCM -scm_options (new_mode, options, n, s) - SCM new_mode; - scm_option options[]; - int n; - char *s; -{ - int i, docp = (!SCM_UNBNDP (new_mode) - && (SCM_IMP (new_mode) || SCM_NCONSP (new_mode))); - SCM ans = SCM_EOL, ls; - for (i = 0; i < n; ++i) - { - ls = docp ? scm_cons ((SCM) options[i].doc, SCM_EOL) : ans; - switch (options[i].type) - { - case SCM_OPTION_BOOLEAN: - if (docp) - ls = scm_cons ((int) options[i].val - ? scm_yes_sym - : scm_no_sym, - ls); - break; - case SCM_OPTION_INTEGER: - ls = scm_cons (SCM_MAKINUM ((int) options[i].val), ls); - break; - case SCM_OPTION_SCM: - ls = scm_cons ((SCM) options[i].val, ls); - } - if (!((options[i].type == SCM_OPTION_BOOLEAN) - && !docp - && ! (int) options[i].val)) - ls = scm_cons ((SCM) options[i].name, ls); - ans = docp ? scm_cons (ls, ans) : ls; - } - if (!(SCM_UNBNDP (new_mode) || docp)) - { - unsigned long *flags; - flags = (unsigned long *) scm_must_malloc (n * sizeof (unsigned long), - "mode buffer"); - for (i = 0; i < n; ++i) - if (options[i].type == SCM_OPTION_BOOLEAN) - flags[i] = 0; - else - flags[i] = (unsigned long) options[i].val; - while (SCM_NNULLP (new_mode)) - { - SCM_ASSERT (SCM_NIMP (new_mode) && SCM_CONSP (new_mode), - new_mode, - SCM_ARG1, - s); - for (i = 0; i < n; ++i) - if (SCM_CAR (new_mode) == (SCM) options[i].name) - switch (options[i].type) - { - case SCM_OPTION_BOOLEAN: - flags[i] = 1; - goto cont; - case SCM_OPTION_INTEGER: - new_mode = SCM_CDR (new_mode); - SCM_ASSERT (SCM_NIMP (new_mode) - && SCM_CONSP (new_mode) - && SCM_INUMP (SCM_CAR (new_mode)), - new_mode, - SCM_ARG1, - s); - flags[i] = (unsigned long) SCM_INUM (SCM_CAR (new_mode)); - goto cont; - case SCM_OPTION_SCM: - new_mode = SCM_CDR (new_mode); - flags[i] = SCM_CAR (new_mode); - goto cont; - } -#ifndef RECKLESS - scm_must_free ((char *) flags); - scm_wta (SCM_CAR (new_mode), "Unknown mode flag", s); -#endif - cont: - new_mode = SCM_CDR (new_mode); - } - for (i = 0; i < n; ++i) options[i].val = flags[i]; - scm_must_free ((char *) flags); - } - return ans; -} - - -void -scm_init_opts (func, options, n) - SCM (*func) (SCM); - scm_option options[]; - int n; -{ - int i; - - for (i = 0; i < n; ++i) - { - options[i].name = (char *) SCM_CAR (scm_sysintern (options[i].name, - SCM_UNDEFINED)); - options[i].doc = (char *) scm_permanent_object (scm_take0str - (options[i].doc)); - } - func (SCM_UNDEFINED); -} - - -void -scm_init_options () -{ -#include "options.x" -} diff --git a/libguile/options.h b/libguile/options.h deleted file mode 100644 index 62b0a7436..000000000 --- a/libguile/options.h +++ /dev/null @@ -1,73 +0,0 @@ -/* classes: h_files */ - -#ifndef OPTIONSH -#define OPTIONSH -/* Copyright (C) 1995,1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include "libguile/__scm.h" - - - -typedef struct scm_option -{ - int type; - char *name; - unsigned long val; - char *doc; -} scm_option; - -#define SCM_OPTION_BOOLEAN 0 -#define SCM_OPTION_INTEGER 1 -#define SCM_OPTION_SCM 2 - -extern SCM scm_yes_sym, scm_no_sym; - - -extern SCM scm_options SCM_P ((SCM new_mode, scm_option options[], int n, char *s)); -extern void scm_init_opts SCM_P ((SCM (*func) (SCM), scm_option options[], int n)); -extern void scm_init_options SCM_P ((void)); - -#endif /* OPTIONSH */ diff --git a/libguile/pairs.c b/libguile/pairs.c deleted file mode 100644 index 619529e64..000000000 --- a/libguile/pairs.c +++ /dev/null @@ -1,163 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" - - - -/* {Pairs} - */ - -SCM_PROC(s_cons, "cons", 2, 0, 0, scm_cons); - -SCM -scm_cons (x, y) - SCM x; - SCM y; -{ - register SCM z; - SCM_NEWCELL (z); - SCM_SETCAR (z, x); - SCM_SETCDR (z, y); - return z; -} - - -SCM -scm_cons2 (w, x, y) - SCM w; - SCM x; - SCM y; -{ - register SCM z; - SCM_NEWCELL (z); - SCM_SETCAR (z, x); - SCM_SETCDR (z, y); - x = z; - SCM_NEWCELL (z); - SCM_SETCAR (z, w); - SCM_SETCDR (z, x); - return z; -} - - -SCM_PROC(s_pair_p, "pair?", 1, 0, 0, scm_pair_p); - -SCM -scm_pair_p(x) - SCM x; -{ - if SCM_IMP(x) return SCM_BOOL_F; - return SCM_CONSP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_set_car_x, "set-car!", 2, 0, 0, scm_set_car_x); - -SCM -scm_set_car_x(pair, value) - SCM pair; - SCM value; -{ - SCM_ASSERT(SCM_NIMP(pair) && SCM_CONSP(pair), pair, SCM_ARG1, s_set_car_x); - SCM_SETCAR (pair, value); - return value; -} - -SCM_PROC(s_set_cdr_x, "set-cdr!", 2, 0, 0, scm_set_cdr_x); - -SCM -scm_set_cdr_x(pair, value) - SCM pair; - SCM value; -{ - SCM_ASSERT(SCM_NIMP(pair) && SCM_CONSP(pair), pair, SCM_ARG1, s_set_cdr_x); - SCM_SETCDR (pair, value); - return value; -} - - - - -static scm_iproc cxrs[] = -{ - {"car", 0}, - {"cdr", 0}, - {"caar", 0}, - {"cadr", 0}, - {"cdar", 0}, - {"cddr", 0}, - {"caaar", 0}, - {"caadr", 0}, - {"cadar", 0}, - {"caddr", 0}, - {"cdaar", 0}, - {"cdadr", 0}, - {"cddar", 0}, - {"cdddr", 0}, - {"caaaar", 0}, - {"caaadr", 0}, - {"caadar", 0}, - {"caaddr", 0}, - {"cadaar", 0}, - {"cadadr", 0}, - {"caddar", 0}, - {"cadddr", 0}, - {"cdaaar", 0}, - {"cdaadr", 0}, - {"cdadar", 0}, - {"cdaddr", 0}, - {"cddaar", 0}, - {"cddadr", 0}, - {"cdddar", 0}, - {"cddddr", 0}, - {0, 0} -}; - - - -void -scm_init_pairs () -{ - scm_init_iprocs(cxrs, scm_tc7_cxr); -#include "pairs.x" -} - diff --git a/libguile/pairs.h b/libguile/pairs.h deleted file mode 100644 index ec074f77b..000000000 --- a/libguile/pairs.h +++ /dev/null @@ -1,172 +0,0 @@ -/* classes: h_files */ - -#ifndef PAIRSH -#define PAIRSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -typedef struct scm_cell -{ - SCM car; - SCM cdr; -} scm_cell; - -/* SCM_PTR_LT defines how to compare two SCM_CELLPTRs (which may not be in the - * same scm_array). SCM_CELLPTR is a pointer to a cons cell which may be - * compared or differenced. SCMPTR is used for stack bounds. - */ - -#if !defined(__TURBOC__) || defined(__TOS__) - -typedef scm_cell *SCM_CELLPTR; -typedef SCM *SCMPTR; - -# ifdef nosve -# define SCM_PTR_MASK 0xffffffffffff -# define SCM_PTR_LT(x, y) (((int)(x)&SCM_PTR_MASK) < ((int)(y)&SCM_PTR_MASK)) -# else -# define SCM_PTR_LT(x, y) ((x) < (y)) -# endif /* def nosve */ - -#else /* defined(__TURBOC__) && !defined(__TOS__) */ - -# ifdef PROT386 -typedef scm_cell *SCM_CELLPTR; -typedef SCM *SCMPTR; -# define SCM_PTR_LT(x, y) (((long)(x)) < ((long)(y))) -# else -typedef scm_cell huge *SCM_CELLPTR; -typedef SCM huge *SCMPTR; -# define SCM_PTR_LT(x, y) ((x) < (y)) -# endif /* def PROT386 */ - -#endif /* defined(__TURBOC__) && !defined(__TOS__) */ - -#define SCM_PTR_GT(x, y) SCM_PTR_LT(y, x) -#define SCM_PTR_LE(x, y) (!SCM_PTR_GT(x, y)) -#define SCM_PTR_GE(x, y) (!SCM_PTR_LT(x, y)) - -#define SCM_NULLP(x) (SCM_EOL == (x)) -#define SCM_NNULLP(x) (SCM_EOL != (x)) - - - - -/* Cons Pairs - */ - -#define SCM_CAR(x) (((scm_cell *)(SCM2PTR(x)))->car) -#define SCM_CDR(x) (((scm_cell *)(SCM2PTR(x)))->cdr) -#define SCM_GCCDR(x) (~1L & SCM_CDR(x)) -#define SCM_SETCAR(x, v) (SCM_CAR(x) = (SCM)(v)) -#define SCM_SETCDR(x, v) (SCM_CDR(x) = (SCM)(v)) - -#define SCM_CARLOC(x) (&SCM_CAR (x)) -#define SCM_CDRLOC(x) (&SCM_CDR (x)) - -#define SCM_SETAND_CAR(x, y) (SCM_CAR (x) &= (y)) -#define SCM_SETAND_CDR(x, y) (SCM_CDR (x) &= (y)) -#define SCM_SETOR_CAR(x, y) (SCM_CAR (x) |= (y)) -#define SCM_SETOR_CDR(x, y) (SCM_CDR (x) |= (y)) - -#define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ)) -#define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ)) -#define SCM_CADR(OBJ) SCM_CAR (SCM_CDR (OBJ)) -#define SCM_CDDR(OBJ) SCM_CDR (SCM_CDR (OBJ)) - -#define SCM_CAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (OBJ))) -#define SCM_CDAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (OBJ))) -#define SCM_CADAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (OBJ))) -#define SCM_CDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (OBJ))) -#define SCM_CAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (OBJ))) -#define SCM_CDADR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (OBJ))) -#define SCM_CADDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (OBJ))) -#define SCM_CDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (OBJ))) - -#define SCM_CAAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ)))) -#define SCM_CDAAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ)))) -#define SCM_CADAAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ)))) -#define SCM_CDDAAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ)))) -#define SCM_CAADAR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ)))) -#define SCM_CDADAR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ)))) -#define SCM_CADDAR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ)))) -#define SCM_CDDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ)))) -#define SCM_CAAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ)))) -#define SCM_CDAADR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ)))) -#define SCM_CADADR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ)))) -#define SCM_CDDADR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ)))) -#define SCM_CAADDR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ)))) -#define SCM_CDADDR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ)))) -#define SCM_CADDDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ)))) -#define SCM_CDDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ)))) - - -#ifdef DEBUG_FREELIST -#define SCM_NEWCELL(_into) (scm_debug_newcell (&_into)) -#else -#define SCM_NEWCELL(_into) \ - { \ - if (SCM_IMP(scm_freelist)) \ - _into = scm_gc_for_newcell();\ - else \ - { \ - _into = scm_freelist; \ - scm_freelist = SCM_CDR(scm_freelist);\ - ++scm_cells_allocated; \ - } \ - } -#endif - - - -extern SCM scm_cons SCM_P ((SCM x, SCM y)); -extern SCM scm_cons2 SCM_P ((SCM w, SCM x, SCM y)); -extern SCM scm_pair_p SCM_P ((SCM x)); -extern SCM scm_set_car_x SCM_P ((SCM pair, SCM value)); -extern SCM scm_set_cdr_x SCM_P ((SCM pair, SCM value)); -extern void scm_init_pairs SCM_P ((void)); - -#endif /* PAIRSH */ diff --git a/libguile/ports.c b/libguile/ports.c deleted file mode 100644 index c2a9406e6..000000000 --- a/libguile/ports.c +++ /dev/null @@ -1,854 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "chars.h" - -#include "markers.h" -#include "filesys.h" -#include "fports.h" -#include "strports.h" -#include "vports.h" - -#include "ports.h" - -#ifdef HAVE_MALLOC_H -#include <malloc.h> -#endif - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - -#ifdef HAVE_SYS_IOCTL_H -#include <sys/ioctl.h> -#endif - - - -/* scm_ptobs scm_numptob - * implement a dynamicly resized array of ptob records. - * Indexes into this table are used when generating type - * tags for smobjects (if you know a tag you can get an index and conversely). - */ -scm_ptobfuns *scm_ptobs; -scm_sizet scm_numptob; - - -SCM -scm_markstream (ptr) - SCM ptr; -{ - int openp; - if (SCM_GC8MARKP (ptr)) - return SCM_BOOL_F; - openp = SCM_CAR (ptr) & SCM_OPN; - SCM_SETGC8MARK (ptr); - if (openp) - return SCM_STREAM (ptr); - else - return SCM_BOOL_F; -} - - - -long -scm_newptob (ptob) - scm_ptobfuns *ptob; -{ - char *tmp; - if (255 <= scm_numptob) - goto ptoberr; - SCM_DEFER_INTS; - SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns))); - if (tmp) - { - scm_ptobs = (scm_ptobfuns *) tmp; - scm_ptobs[scm_numptob].mark = ptob->mark; - scm_ptobs[scm_numptob].free = ptob->free; - scm_ptobs[scm_numptob].print = ptob->print; - scm_ptobs[scm_numptob].equalp = ptob->equalp; - scm_ptobs[scm_numptob].fputc = ptob->fputc; - scm_ptobs[scm_numptob].fputs = ptob->fputs; - scm_ptobs[scm_numptob].fwrite = ptob->fwrite; - scm_ptobs[scm_numptob].fflush = ptob->fflush; - scm_ptobs[scm_numptob].fgetc = ptob->fgetc; - scm_ptobs[scm_numptob].fclose = ptob->fclose; - scm_numptob++; - } - SCM_ALLOW_INTS; - if (!tmp) - ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), (char *) SCM_NALLOC, "newptob"); - return scm_tc7_port + (scm_numptob - 1) * 256; -} - - -/* internal SCM call */ - -void -scm_fflush (port) - SCM port; -{ - scm_sizet i = SCM_PTOBNUM (port); - (scm_ptobs[i].fflush) (SCM_STREAM (port)); -} - - - -SCM_PROC(s_char_ready_p, "char-ready?", 1, 0, 0, scm_char_ready_p); - -SCM -scm_char_ready_p (port) - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_char_ready_p); - if (SCM_CRDYP (port) || !SCM_FPORTP (port)) - return SCM_BOOL_T; - return (scm_input_waiting_p ((FILE *) SCM_STREAM (port), s_char_ready_p) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - - -SCM_PROC (s_ungetc_char_ready_p, "ungetc-char-ready?", 1, 0, 0, scm_ungetc_char_ready_p); - -SCM -scm_ungetc_char_ready_p (port) - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_ungetc_char_ready_p); - return (SCM_CRDYP (port) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - - - -/* {Standard Ports} - */ -SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port); - -SCM -scm_current_input_port () -{ - return scm_cur_inp; -} - -SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port); - -SCM -scm_current_output_port () -{ - return scm_cur_outp; -} - -SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port); - -SCM -scm_current_error_port () -{ - return scm_cur_errp; -} - -SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port); - -SCM -scm_set_current_input_port (port) - SCM port; -{ - SCM oinp = scm_cur_inp; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port); - scm_cur_inp = port; - return oinp; -} - - -SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port); - -SCM -scm_set_current_output_port (port) - SCM port; -{ - SCM ooutp = scm_cur_outp; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port); - scm_cur_outp = port; - return ooutp; -} - - -SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port); - -SCM -scm_set_current_error_port (port) - SCM port; -{ - SCM oerrp = scm_cur_errp; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port); - scm_cur_errp = port; - return oerrp; -} - - - -/* {Ports - in general} - * - */ - -/* Array of open ports, required for reliable MOVE->FDES etc. */ -struct scm_port_table **scm_port_table; - -int scm_port_table_size = 0; /* Number of ports in scm_port_table. */ -int scm_port_table_room = 20; /* Size of the array. */ - -/* Add a port to the table. Call with SCM_DEFER_INTS active. */ - -struct scm_port_table * -scm_add_to_port_table (port) - SCM port; -{ - if (scm_port_table_size == scm_port_table_room) - { - scm_port_table = ((struct scm_port_table **) - realloc ((char *) scm_port_table, - (long) (sizeof (struct scm_port_table) - * scm_port_table_room * 2))); - /* !!! error checking */ - scm_port_table_room *= 2; - } - scm_port_table[scm_port_table_size] = ((struct scm_port_table *) - scm_must_malloc (sizeof (struct scm_port_table), - "system port table")); - scm_port_table[scm_port_table_size]->port = port; - scm_port_table[scm_port_table_size]->revealed = 0; - scm_port_table[scm_port_table_size]->stream = 0; - scm_port_table[scm_port_table_size]->file_name = SCM_BOOL_F; - scm_port_table[scm_port_table_size]->line_number = 1; - scm_port_table[scm_port_table_size]->column_number = 0; - scm_port_table[scm_port_table_size]->representation = scm_regular_port; - return scm_port_table[scm_port_table_size++]; -} - -/* Remove a port from the table. Call with SCM_DEFER_INTS active. */ - -void -scm_remove_from_port_table (port) - SCM port; -{ - int i = 0; - while (scm_port_table[i]->port != port) - { - i++; - /* Error if not found: too violent? May occur in GC. */ - if (i >= scm_port_table_size) - scm_wta (port, "Port not in table", "scm_remove_from_port_table"); - } - scm_must_free ((char *)scm_port_table[i]); - scm_mallocated -= sizeof (*scm_port_table[i]); - scm_port_table[i] = scm_port_table[scm_port_table_size - 1]; - SCM_SETPTAB_ENTRY (port, 0); - scm_port_table_size--; -} - -#ifdef DEBUG -/* Undocumented functions for debugging. */ -/* Return the number of ports in the table. */ -static char s_pt_size[] = "pt-size"; - -SCM -scm_pt_size () -{ - return SCM_MAKINUM (scm_port_table_size); -} - -/* Return the ith member of the port table. */ -static char s_pt_member[] = "pt-member"; - -SCM -scm_pt_member (member) - SCM member; -{ - int i; - SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member); - i = SCM_INUM (member); - if (i < 0 || i >= scm_port_table_size) - return SCM_BOOL_F; - else - return scm_port_table[i]->port; -} -#endif - - -/* Find a port in the table and return its revealed count. - Also used by the garbage collector. - */ - -int -scm_revealed_count (port) - SCM port; -{ - return SCM_REVEALED(port); -} - - - -/* Return the revealed count for a port. */ - -SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed); - -SCM -scm_port_revealed (port) - SCM port; -{ - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed); - return SCM_MAKINUM (scm_revealed_count (port)); -} - -/* Set the revealed count for a port. */ -SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x); - -SCM -scm_set_port_revealed_x (port, rcount) - SCM port; - SCM rcount; -{ - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x); - SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x); - SCM_DEFER_INTS; - SCM_REVEALED (port) = SCM_INUM (rcount); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - -/* scm_close_port - * Call the close operation on a port object. - */ -SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port); - -SCM -scm_close_port (port) - SCM port; -{ - scm_sizet i; - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_close_port); - if (SCM_CLOSEDP (port)) - return SCM_UNSPECIFIED; - i = SCM_PTOBNUM (port); - SCM_DEFER_INTS; - if (scm_ptobs[i].fclose) - SCM_SYSCALL ((scm_ptobs[i].fclose) (SCM_STREAM (port))); - scm_remove_from_port_table (port); - SCM_SETAND_CAR (port, ~SCM_OPN); - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except); - -SCM -scm_close_all_ports_except (ports) - SCM ports; -{ - int i = 0; - SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except); - SCM_DEFER_INTS; - while (i < scm_port_table_size) - { - SCM thisport = scm_port_table[i]->port; - int found = 0; - SCM ports_ptr = ports; - - while (SCM_NNULLP (ports_ptr)) - { - SCM port = SCM_CAR (ports_ptr); - if (i == 0) - SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except); - if (port == thisport) - found = 1; - ports_ptr = SCM_CDR (ports_ptr); - } - if (found) - i++; - else - /* i is not to be incremented here. */ - scm_close_port (thisport); - } - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p); - -SCM -scm_input_port_p (x) - SCM x; -{ - if (SCM_IMP (x)) - return SCM_BOOL_F; - return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p); - -SCM -scm_output_port_p (x) - SCM x; -{ - if (SCM_IMP (x)) - return SCM_BOOL_F; - return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F; -} - - -SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p); - -SCM -scm_eof_object_p (x) - SCM x; -{ - return (SCM_EOF_VAL == x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output); - -SCM -scm_force_output (port) - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_force_output); - { - scm_sizet i = SCM_PTOBNUM (port); - SCM_SYSCALL ((scm_ptobs[i].fflush) (SCM_STREAM (port))); - return SCM_UNSPECIFIED; - } -} - - -SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char); - -SCM -scm_read_char (port) - SCM port; -{ - int c; - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char); - c = scm_gen_getc (port); - if (EOF == c) - return SCM_EOF_VAL; - return SCM_MAKICHR (c); -} - - -SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char); - -SCM -scm_peek_char (port) - SCM port; -{ - int c; - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char); - c = scm_gen_getc (port); - if (EOF == c) - return SCM_EOF_VAL; - scm_gen_ungetc (c, port); - return SCM_MAKICHR (c); -} - -SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char); - -SCM -scm_unread_char (cobj, port) - SCM cobj; - SCM port; -{ - int c; - - SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char); - - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char); - - - c = SCM_ICHR (cobj); - - scm_gen_ungetc (c, port); - return cobj; -} - - - -SCM_PROC (s_port_line, "port-line", 0, 1, 0, scm_port_line); - -SCM -scm_port_line (port) - SCM port; -{ - SCM p; - p = ((port == SCM_UNDEFINED) - ? scm_cur_inp - : port); - if (!(SCM_NIMP (p) && SCM_PORTP (p))) - return SCM_BOOL_F; - else - return SCM_MAKINUM (SCM_LINUM (p)); -} - -SCM_PROC (s_set_port_line_x, "set-port-line!", 1, 1, 0, scm_set_port_line_x); - -SCM -scm_set_port_line_x (port, line) - SCM port; - SCM line; -{ - if (line == SCM_UNDEFINED) - { - line = port; - port = scm_cur_inp; - } - else - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_set_port_line_x); - return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line); -} - -SCM_PROC (s_port_column, "port-column", 0, 1, 0, scm_port_column); - -SCM -scm_port_column (port) - SCM port; -{ - SCM p; - p = ((port == SCM_UNDEFINED) - ? scm_cur_inp - : port); - if (!(SCM_NIMP (p) && SCM_PORTP (p))) - return SCM_BOOL_F; - else - return SCM_MAKINUM (SCM_COL (p)); -} - -SCM_PROC (s_set_port_column_x, "set-port-column!", 1, 1, 0, scm_set_port_column_x); - -SCM -scm_set_port_column_x (port, column) - SCM port; - SCM column; -{ - if (column == SCM_UNDEFINED) - { - column = port; - port = scm_cur_inp; - } - else - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_set_port_column_x); - return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column); -} - -SCM_PROC (s_port_filename, "port-filename", 0, 1, 0, scm_port_filename); - -SCM -scm_port_filename (port) - SCM port; -{ - SCM p; - p = ((port == SCM_UNDEFINED) - ? scm_cur_inp - : port); - if (!(SCM_NIMP (p) && SCM_PORTP (p))) - return SCM_BOOL_F; - else - return SCM_PTAB_ENTRY (p)->file_name; -} - -SCM_PROC (s_set_port_filename_x, "set-port-filename!", 1, 1, 0, scm_set_port_filename_x); - -SCM -scm_set_port_filename_x (port, filename) - SCM port; - SCM filename; -{ - if (filename == SCM_UNDEFINED) - { - filename = port; - port = scm_cur_inp; - } - else - SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port), - port, - SCM_ARG1, - s_set_port_filename_x); - return SCM_PTAB_ENTRY (port)->file_name = filename; -} - -#ifndef ttyname -extern char * ttyname(); -#endif - - -void -scm_prinport (exp, port, type) - SCM exp; - SCM port; - char *type; -{ - scm_gen_puts (scm_regular_string, "#<", port); - if (SCM_CLOSEDP (exp)) - scm_gen_puts (scm_regular_string, "closed: ", port); - else - { - if (SCM_RDNG & SCM_CAR (exp)) - scm_gen_puts (scm_regular_string, "input: ", port); - if (SCM_WRTNG & SCM_CAR (exp)) - scm_gen_puts (scm_regular_string, "output: ", port); - } - scm_gen_puts (scm_regular_string, type, port); - scm_gen_putc (' ', port); -#ifndef MSDOS -#ifndef __EMX__ -#ifndef _DCC -#ifndef AMIGA -#ifndef THINK_C - if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp)))) - scm_gen_puts (scm_regular_string, ttyname (fileno ((FILE *)SCM_STREAM (exp))), port); - else -#endif -#endif -#endif -#endif -#endif - if (SCM_OPFPORTP (exp)) - scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port); - else - scm_intprint (SCM_CDR (exp), 16, port); - scm_gen_putc ('>', port); -} - - -void -scm_ports_prehistory () -{ - scm_numptob = 0; - scm_ptobs = (scm_ptobfuns *) malloc (sizeof (scm_ptobfuns)); - - /* WARNING: These scm_newptob calls must be done in this order. - * They must agree with the port declarations in tags.h. - */ - /* scm_tc16_fport = */ scm_newptob (&scm_fptob); - /* scm_tc16_pipe = */ scm_newptob (&scm_pipob); - /* scm_tc16_strport = */ scm_newptob (&scm_stptob); - /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob); -} - - - -/* {Void Ports} - */ - -int scm_tc16_void_port = 0; - -static int -print_void_port (exp, port, writing) - SCM exp; - SCM port; - int writing; -{ - scm_prinport (exp, port, "void"); - return 1; -} - -static int -putc_void_port (c, strm) - int c; - SCM strm; -{ - return 0; /* vestigial return value */ -} - -static int -puts_void_port (s, strm) - char * s; - SCM strm; -{ - return 0; /* vestigial return value */ -} - -static scm_sizet -write_void_port (ptr, size, nitems, strm) - void * ptr; - int size; - int nitems; - SCM strm; -{ - int len; - len = size * nitems; - return len; -} - - -static int flush_void_port SCM_P ((SCM strm)); - -static int -flush_void_port (strm) - SCM strm; -{ - return 0; -} - - -static int getc_void_port SCM_P ((SCM strm)); - -static int -getc_void_port (strm) - SCM strm; -{ - return EOF; -} - - -static int close_void_port SCM_P ((SCM strm)); - -static int -close_void_port (strm) - SCM strm; -{ - return 0; /* this is ignored by scm_close_port. */ -} - - - -static int noop0 SCM_P ((SCM stream)); - -static int -noop0 (stream) - SCM stream; -{ - return 0; -} - - -static struct scm_ptobfuns void_port_ptob = -{ - scm_mark0, - noop0, - print_void_port, - 0, /* equal? */ - putc_void_port, - puts_void_port, - write_void_port, - flush_void_port, - getc_void_port, - close_void_port, -}; - - - - -SCM -scm_void_port (mode_str) - char * mode_str; -{ - int mode_bits; - SCM answer; - struct scm_port_table * pt; - - SCM_NEWCELL (answer); - SCM_DEFER_INTS; - mode_bits = scm_mode_bits (mode_str); - pt = scm_add_to_port_table (answer); - SCM_SETCAR (answer, scm_tc16_void_port | mode_bits); - SCM_SETPTAB_ENTRY (answer, pt); - SCM_SETSTREAM (answer, SCM_BOOL_F); - SCM_ALLOW_INTS; - return answer; -} - - -SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port); - -SCM -scm_sys_make_void_port (mode) - SCM mode; -{ - SCM_ASSERT (SCM_NIMP (mode) && SCM_STRINGP (mode), mode, - SCM_ARG1, s_sys_make_void_port); - - return scm_void_port (SCM_ROCHARS (mode)); -} - - - - - - -void -scm_init_ports () -{ - scm_tc16_void_port = scm_newptob (&void_port_ptob); -#include "ports.x" -} - diff --git a/libguile/ports.h b/libguile/ports.h deleted file mode 100644 index 55875b197..000000000 --- a/libguile/ports.h +++ /dev/null @@ -1,200 +0,0 @@ -/* classes: h_files */ - -#ifndef PORTSH -#define PORTSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -enum scm_port_representation_type -{ - scm_regular_port, - scm_mb_port, - scm_wchar_port -}; - -enum scm_string_representation_type -{ - scm_regular_string = scm_regular_port, - scm_mb_string = scm_mb_port, - scm_wchar_string = scm_wchar_port -}; - - -struct scm_port_table -{ - SCM port; /* Open port. */ - int revealed; /* 0 not revealed, > 1 revealed. - * Revealed ports do not get GC'd. - */ - - SCM stream; - SCM file_name; /* debugging support. */ - int unchr; /* pushed back character, if any */ - - int line_number; /* debugging support. */ - int column_number; /* debugging support. */ - - enum scm_port_representation_type representation; -}; - -extern struct scm_port_table **scm_port_table; -extern int scm_port_table_size; /* Number of ports in scm_port_table. */ - - - - -/* PORT FLAGS - * A set of flags characterizes a port. - */ -#define SCM_OPN (1L<<16) /* Is the port open? */ -#define SCM_RDNG (2L<<16) /* Is it a readable port? */ -#define SCM_WRTNG (4L<<16) /* Is it writable? */ -#define SCM_BUF0 (8L<<16) -#define SCM_CRDY (32L<<16) /* Should char-ready? return #t? */ - -/* A mask used to clear the char-ready port flag. */ -#define SCM_CUC 0x001fffffL - -#define SCM_PORTP(x) (SCM_TYP7(x)==scm_tc7_port) -#define SCM_OPPORTP(x) (((0x7f | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN)) -#define SCM_OPINPORTP(x) (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)) -#define SCM_OPOUTPORTP(x) (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)) -#define SCM_FPORTP(x) (SCM_TYP16S(x)==scm_tc7_port) -#define SCM_OPFPORTP(x) (((0xfeff | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN)) -#define SCM_OPINFPORTP(x) (((0xfeff | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)) -#define SCM_OPOUTFPORTP(x) (((0xfeff | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)) - -#define SCM_INPORTP(x) (((0x7f | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_RDNG)) -#define SCM_OUTPORTP(x) (((0x7f | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_WRTNG)) -#define SCM_OPENP(x) (SCM_OPN & SCM_CAR(x)) -#define SCM_CLOSEDP(x) (!SCM_OPENP(x)) -#define SCM_PTAB_ENTRY(x) ((struct scm_port_table *)SCM_CDR(x)) -#define SCM_SETPTAB_ENTRY(x,ent) SCM_SETCDR ((x), (SCM)(ent)) -#define SCM_STREAM(x) SCM_PTAB_ENTRY(x)->stream -#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = s) -#define SCM_FILENAME(x) SCM_PTAB_ENTRY(x)->file_name -#define SCM_LINUM(x) SCM_PTAB_ENTRY(x)->line_number -#define SCM_COL(x) SCM_PTAB_ENTRY(x)->column_number -#define SCM_REVEALED(x) SCM_PTAB_ENTRY(x)->revealed -#define SCM_SETREVEALED(x,s) (SCM_PTAB_ENTRY(x)->revealed = s) -#define SCM_PORT_REPRESENTATION(x) SCM_PTAB_ENTRY(x)->representation -#define SCM_SET_PORT_REPRESENTATION(x,s) (SCM_PTAB_ENTRY(x)->representation = s) -#define SCM_CRDYP(port) (SCM_CAR (port) & SCM_CRDY) -#define SCM_CLRDY(port) {SCM_SETAND_CAR (port, SCM_CUC);} -#define SCM_SETRDY(port) {SCM_SETOR_CAR (port, SCM_CRDY);} -#define SCM_CUNGET(c,port) {SCM_PTAB_ENTRY(port)->unchr = c; SCM_SETRDY(port);} -#define SCM_CGETUN(port) (SCM_PTAB_ENTRY(port)->unchr) - -#define SCM_INCLINE(port) {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} -#define SCM_INCCOL(port) {SCM_COL (port) += 1;} -#define SCM_TABCOL(port) {SCM_COL (port) += 8 - SCM_COL (port) % 8;} - - - - - -typedef struct scm_ptobfuns -{ - SCM (*mark) SCM_P ((SCM)); - int (*free) SCM_P ((SCM)); - int (*print) SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - SCM (*equalp) SCM_P ((SCM, SCM)); - int (*fputc) SCM_P ((int, SCM stream)); - int (*fputs) SCM_P ((char *, SCM stream)); - scm_sizet (*fwrite) SCM_P ((char *ptr, scm_sizet size, scm_sizet nitems, SCM stream)); - int (*fflush) SCM_P ((SCM stream)); - int (*fgetc) SCM_P ((SCM stream)); - int (*fclose) SCM_P ((SCM stream)); -} scm_ptobfuns; - -#define SCM_PTOBNUM(x) (0x0ff & (SCM_CAR(x)>>8)); - - - -extern scm_ptobfuns *scm_ptobs; -extern scm_sizet scm_numptob; -extern int scm_port_table_room; - - - -extern SCM scm_markstream SCM_P ((SCM ptr)); -extern long scm_newptob SCM_P ((scm_ptobfuns *ptob)); -extern void scm_fflush SCM_P ((SCM port)); -extern SCM scm_char_ready_p SCM_P ((SCM port)); -extern SCM scm_ungetc_char_ready_p SCM_P ((SCM port)); -extern SCM scm_current_input_port SCM_P ((void)); -extern SCM scm_current_output_port SCM_P ((void)); -extern SCM scm_current_error_port SCM_P ((void)); -extern SCM scm_set_current_input_port SCM_P ((SCM port)); -extern SCM scm_set_current_output_port SCM_P ((SCM port)); -extern SCM scm_set_current_error_port SCM_P ((SCM port)); -extern struct scm_port_table * scm_add_to_port_table SCM_P ((SCM port)); -extern void scm_remove_from_port_table SCM_P ((SCM port)); -extern SCM scm_pt_size SCM_P ((void)); -extern SCM scm_pt_member SCM_P ((SCM member)); -extern int scm_revealed_count SCM_P ((SCM port)); -extern SCM scm_port_revealed SCM_P ((SCM port)); -extern SCM scm_set_port_revealed_x SCM_P ((SCM port, SCM rcount)); -extern SCM scm_close_port SCM_P ((SCM port)); -extern SCM scm_close_all_ports_except SCM_P ((SCM ports)); -extern SCM scm_input_port_p SCM_P ((SCM x)); -extern SCM scm_output_port_p SCM_P ((SCM x)); -extern SCM scm_eof_object_p SCM_P ((SCM x)); -extern SCM scm_force_output SCM_P ((SCM port)); -extern SCM scm_read_char SCM_P ((SCM port)); -extern SCM scm_peek_char SCM_P ((SCM port)); -extern SCM scm_unread_char SCM_P ((SCM cobj, SCM port)); -extern SCM scm_port_line SCM_P ((SCM port)); -extern SCM scm_port_column SCM_P ((SCM port)); -extern SCM scm_port_filename SCM_P ((SCM port)); -extern SCM scm_set_port_filename_x SCM_P ((SCM port, SCM filename)); -extern void scm_prinport SCM_P ((SCM exp, SCM port, char *type)); -extern void scm_ports_prehistory SCM_P ((void)); -extern SCM scm_void_port SCM_P ((char * mode_str)); -extern SCM scm_sys_make_void_port SCM_P ((SCM mode)); -extern void scm_init_ports SCM_P ((void)); - -#endif /* PORTSH */ diff --git a/libguile/posix.c b/libguile/posix.c deleted file mode 100644 index ebdbf202c..000000000 --- a/libguile/posix.c +++ /dev/null @@ -1,1461 +0,0 @@ -/* Copyright (C) 1995, 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "fports.h" -#include "genio.h" -#include "scmsigs.h" -#include "read.h" -#include "unif.h" -#include "feature.h" -#include "sequences.h" - -#include "posix.h" - - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef TIME_WITH_SYS_TIME -# include <sys/time.h> -# include <time.h> -#else -# if HAVE_SYS_TIME_H -# include <sys/time.h> -# else -# include <time.h> -# endif -#endif - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#else -#ifndef ttyname -extern char *ttyname(); -#endif -#endif - -#ifdef LIBC_H_WITH_UNISTD_H -#include <libc.h> -#endif - -#ifdef HAVE_SYS_SELECT_H -#include <sys/select.h> -#endif - -#include <sys/types.h> -#include <sys/stat.h> -#include <fcntl.h> - -#include <pwd.h> - -#if HAVE_SYS_WAIT_H -# include <sys/wait.h> -#endif -#ifndef WEXITSTATUS -# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8) -#endif -#ifndef WIFEXITED -# define WIFEXITED(stat_val) (((stat_val) & 255) == 0) -#endif - -#include <signal.h> - -#ifdef FD_SET - -#define SELECT_TYPE fd_set -#define SELECT_SET_SIZE FD_SETSIZE - -#else /* no FD_SET */ - -/* Define the macros to access a single-int bitmap of descriptors. */ -#define SELECT_SET_SIZE 32 -#define SELECT_TYPE int -#define FD_SET(n, p) (*(p) |= (1 << (n))) -#define FD_CLR(n, p) (*(p) &= ~(1 << (n))) -#define FD_ISSET(n, p) (*(p) & (1 << (n))) -#define FD_ZERO(p) (*(p) = 0) - -#endif /* no FD_SET */ - -extern FILE *popen (); -extern char ** environ; - -#include <grp.h> -#include <sys/utsname.h> - -#if HAVE_DIRENT_H -# include <dirent.h> -# define NAMLEN(dirent) strlen((dirent)->d_name) -#else -# define dirent direct -# define NAMLEN(dirent) (dirent)->d_namlen -# if HAVE_SYS_NDIR_H -# include <sys/ndir.h> -# endif -# if HAVE_SYS_DIR_H -# include <sys/dir.h> -# endif -# if HAVE_NDIR_H -# include <ndir.h> -# endif -#endif - -char *strptime (); - -#ifdef HAVE_SETLOCALE -#include <locale.h> -#endif - -/* Some Unix systems don't define these. CPP hair is dangerous, but - this seems safe enough... */ -#ifndef R_OK -#define R_OK 4 -#endif - -#ifndef W_OK -#define W_OK 2 -#endif - -#ifndef X_OK -#define X_OK 1 -#endif - -#ifndef F_OK -#define F_OK 0 -#endif - -/* On NextStep, <utime.h> doesn't define struct utime, unless we - #define _POSIX_SOURCE before #including it. I think this is less - of a kludge than defining struct utimbuf ourselves. */ -#ifdef UTIMBUF_NEEDS_POSIX -#define _POSIX_SOURCE -#endif - -#ifdef HAVE_SYS_UTIME_H -#include <sys/utime.h> -#endif - -#ifdef HAVE_UTIME_H -#include <utime.h> -#endif - -/* Please don't add any more #includes or #defines here. The hack - above means that _POSIX_SOURCE may be #defined, which will - encourage header files to do strange things. */ - - - - -SCM_PROC (s_pipe, "pipe", 0, 0, 0, scm_pipe); - -SCM -scm_pipe () -{ - int fd[2], rv; - FILE *f_rd, *f_wt; - SCM p_rd, p_wt; - struct scm_port_table * ptr; - struct scm_port_table * ptw; - - SCM_NEWCELL (p_rd); - SCM_NEWCELL (p_wt); - rv = pipe (fd); - if (rv) - scm_syserror (s_pipe); - f_rd = fdopen (fd[0], "r"); - if (!f_rd) - { - SCM_SYSCALL (close (fd[0])); - SCM_SYSCALL (close (fd[1])); - scm_syserror (s_pipe); - } - f_wt = fdopen (fd[1], "w"); - if (!f_wt) - { - int en; - en = errno; - fclose (f_rd); - SCM_SYSCALL (close (fd[1])); - errno = en; - scm_syserror (s_pipe); - } - ptr = scm_add_to_port_table (p_rd); - ptw = scm_add_to_port_table (p_wt); - SCM_SETPTAB_ENTRY (p_rd, ptr); - SCM_SETPTAB_ENTRY (p_wt, ptw); - SCM_SETCAR (p_rd, scm_tc16_fport | scm_mode_bits ("r")); - SCM_SETCAR (p_wt, scm_tc16_fport | scm_mode_bits ("w")); - SCM_SETSTREAM (p_rd, (SCM)f_rd); - SCM_SETSTREAM (p_wt, (SCM)f_wt); - - SCM_ALLOW_INTS; - return scm_cons (p_rd, p_wt); -} - - - -SCM_PROC (s_getgroups, "getgroups", 0, 0, 0, scm_getgroups); - -SCM -scm_getgroups() -{ - SCM grps, ans; - int ngroups = getgroups (0, NULL); - if (!ngroups) - scm_syserror (s_getgroups); - SCM_NEWCELL(grps); - SCM_DEFER_INTS; - { - GETGROUPS_T *groups; - int val; - - groups = (GETGROUPS_T *) scm_must_malloc(ngroups * sizeof(GETGROUPS_T), - s_getgroups); - val = getgroups(ngroups, groups); - if (val < 0) - { - scm_must_free((char *)groups); - scm_syserror (s_getgroups); - } - SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */ - SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string); - SCM_ALLOW_INTS; - ans = scm_make_vector(SCM_MAKINUM(ngroups), SCM_UNDEFINED, SCM_BOOL_F); - while (--ngroups >= 0) SCM_VELTS(ans)[ngroups] = SCM_MAKINUM(groups[ngroups]); - SCM_SETCHARS(grps, groups); /* to make sure grps stays around. */ - return ans; - } -} - - - -SCM_PROC (s_getpwuid, "getpw", 0, 1, 0, scm_getpwuid); - -SCM -scm_getpwuid (user) - SCM user; -{ - SCM result; - struct passwd *entry; - SCM *ve; - - result = scm_make_vector (SCM_MAKINUM (7), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (result); - if (SCM_UNBNDP (user) || SCM_FALSEP (user)) - { - SCM_DEFER_INTS; - SCM_SYSCALL (entry = getpwent ()); - } - else if (SCM_INUMP (user)) - { - SCM_DEFER_INTS; - entry = getpwuid (SCM_INUM (user)); - } - else - { - SCM_ASSERT (SCM_NIMP (user) && SCM_ROSTRINGP (user), user, SCM_ARG1, s_getpwuid); - if (SCM_SUBSTRP (user)) - user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0); - SCM_DEFER_INTS; - entry = getpwnam (SCM_ROCHARS (user)); - } - if (!entry) - scm_syserror (s_getpwuid); - - ve[0] = scm_makfrom0str (entry->pw_name); - ve[1] = scm_makfrom0str (entry->pw_passwd); - ve[2] = scm_ulong2num ((unsigned long) entry->pw_uid); - ve[3] = scm_ulong2num ((unsigned long) entry->pw_gid); - ve[4] = scm_makfrom0str (entry->pw_gecos); - if (!entry->pw_dir) - ve[5] = scm_makfrom0str (""); - else - ve[5] = scm_makfrom0str (entry->pw_dir); - if (!entry->pw_shell) - ve[6] = scm_makfrom0str (""); - else - ve[6] = scm_makfrom0str (entry->pw_shell); - SCM_ALLOW_INTS; - return result; -} - - - -SCM_PROC (s_setpwent, "setpw", 0, 1, 0, scm_setpwent); - -SCM -scm_setpwent (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) - endpwent (); - else - setpwent (); - return SCM_UNSPECIFIED; -} - - - -/* Combines getgrgid and getgrnam. */ -SCM_PROC (s_getgrgid, "getgr", 0, 1, 0, scm_getgrgid); - -SCM -scm_getgrgid (name) - SCM name; -{ - SCM result; - struct group *entry; - SCM *ve; - result = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (result); - SCM_DEFER_INTS; - if (SCM_UNBNDP (name) || (name == SCM_BOOL_F)) - SCM_SYSCALL (entry = getgrent ()); - else if (SCM_INUMP (name)) - SCM_SYSCALL (entry = getgrgid (SCM_INUM (name))); - else - { - SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, SCM_ARG1, s_getgrgid); - if (SCM_SUBSTRP (name)) - name = scm_makfromstr (SCM_ROCHARS (name), SCM_ROLENGTH (name), 0); - SCM_SYSCALL (entry = getgrnam (SCM_CHARS (name))); - } - if (!entry) - scm_syserror (s_getgrgid); - - ve[0] = scm_makfrom0str (entry->gr_name); - ve[1] = scm_makfrom0str (entry->gr_passwd); - ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid); - ve[3] = scm_makfromstrs (-1, entry->gr_mem); - SCM_ALLOW_INTS; - return result; -} - - - -SCM_PROC (s_setgrent, "setgr", 0, 1, 0, scm_setgrent); - -SCM -scm_setgrent (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) - endgrent (); - else - setgrent (); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_kill, "kill", 2, 0, 0, scm_kill); - -SCM -scm_kill (pid, sig) - SCM pid; - SCM sig; -{ - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_kill); - SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_kill); - /* Signal values are interned in scm_init_posix(). */ - if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0) - scm_syserror (s_kill); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC (s_waitpid, "waitpid", 1, 1, 0, scm_waitpid); - -SCM -scm_waitpid (pid, options) - SCM pid; - SCM options; -{ -#ifdef HAVE_WAITPID - int i; - int status; - int ioptions; - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_waitpid); - if (SCM_UNBNDP (options)) - ioptions = 0; - else - { - SCM_ASSERT (SCM_INUMP (options), options, SCM_ARG2, s_waitpid); - /* Flags are interned in scm_init_posix. */ - ioptions = SCM_INUM (options); - } - SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions)); - if (i == -1) - scm_syserror (s_waitpid); - return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status)); -#else - scm_sysmissing (s_waitpid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - - -SCM_PROC (s_getppid, "getppid", 0, 0, 0, scm_getppid); - -SCM -scm_getppid () -{ - return SCM_MAKINUM (0L + getppid ()); -} - - - -SCM_PROC (s_getuid, "getuid", 0, 0, 0, scm_getuid); - -SCM -scm_getuid () -{ - return SCM_MAKINUM (0L + getuid ()); -} - - - -SCM_PROC (s_getgid, "getgid", 0, 0, 0, scm_getgid); - -SCM -scm_getgid () -{ - return SCM_MAKINUM (0L + getgid ()); -} - - - -SCM_PROC (s_geteuid, "geteuid", 0, 0, 0, scm_geteuid); - -SCM -scm_geteuid () -{ -#ifdef HAVE_GETEUID - return SCM_MAKINUM (0L + geteuid ()); -#else - return SCM_MAKINUM (0L + getuid ()); -#endif -} - - - -SCM_PROC (s_getegid, "getegid", 0, 0, 0, scm_getegid); - -SCM -scm_getegid () -{ -#ifdef HAVE_GETEUID - return SCM_MAKINUM (0L + getegid ()); -#else - return SCM_MAKINUM (0L + getgid ()); -#endif -} - - -SCM_PROC (s_setuid, "setuid", 1, 0, 0, scm_setuid); - -SCM -scm_setuid (id) - SCM id; -{ - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setuid); - if (setuid (SCM_INUM (id)) != 0) - scm_syserror (s_setuid); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setgid, "setgid", 1, 0, 0, scm_setgid); - -SCM -scm_setgid (id) - SCM id; -{ - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setgid); - if (setgid (SCM_INUM (id)) != 0) - scm_syserror (s_setgid); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_seteuid, "seteuid", 1, 0, 0, scm_seteuid); - -SCM -scm_seteuid (id) - SCM id; -{ - int rv; - - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_seteuid); -#ifdef HAVE_SETEUID - rv = seteuid (SCM_INUM (id)); -#else - rv = setuid (SCM_INUM (id)); -#endif - if (rv != 0) - scm_syserror (s_seteuid); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setegid, "setegid", 1, 0, 0, scm_setegid); - -SCM -scm_setegid (id) - SCM id; -{ - int rv; - - SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setegid); -#ifdef HAVE_SETEUID - rv = setegid (SCM_INUM (id)); -#else - rv = setgid (SCM_INUM (id)); -#endif - if (rv != 0) - scm_syserror (s_setegid); - return SCM_UNSPECIFIED; - -} - -SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp); -SCM -scm_getpgrp () -{ - int (*fn)(); - fn = (int (*) ()) getpgrp; - return SCM_MAKINUM (fn (0)); -} - -SCM_PROC (s_setpgid, "setpgid", 2, 0, 0, scm_setpgid); -SCM -scm_setpgid (pid, pgid) - SCM pid, pgid; -{ -#ifdef HAVE_SETPGID - SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_setpgid); - SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_setpgid); - /* FIXME(?): may be known as setpgrp. */ - if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0) - scm_syserror (s_setpgid); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_setpgid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_setsid, "setsid", 0, 0, 0, scm_setsid); -SCM -scm_setsid () -{ -#ifdef HAVE_SETSID - pid_t sid = setsid (); - if (sid == -1) - scm_syserror (s_setsid); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_setsid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_ttyname, "ttyname", 1, 0, 0, scm_ttyname); - -SCM -scm_ttyname (port) - SCM port; -{ - char *ans; - int fd; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_ttyname); - if (scm_tc16_fport != SCM_TYP16 (port)) - return SCM_BOOL_F; - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1) - scm_syserror (s_ttyname); - SCM_SYSCALL (ans = ttyname (fd)); - if (!ans) - scm_syserror (s_ttyname); - /* ans could be overwritten by another call to ttyname */ - return (scm_makfrom0str (ans)); -} - - -SCM_PROC (s_ctermid, "ctermid", 0, 0, 0, scm_ctermid); -SCM -scm_ctermid () -{ -#ifdef HAVE_CTERMID - char *result = ctermid (NULL); - if (*result == '\0') - scm_syserror (s_ctermid); - return scm_makfrom0str (result); -#else - scm_sysmissing (s_ctermid); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_tcgetpgrp, "tcgetpgrp", 1, 0, 0, scm_tcgetpgrp); -SCM -scm_tcgetpgrp (port) - SCM port; -{ -#ifdef HAVE_TCGETPGRP - int fd; - pid_t pgid; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp); - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1) - scm_syserror (s_tcgetpgrp); - return SCM_MAKINUM (pgid); -#else - scm_sysmissing (s_tcgetpgrp); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_tcsetpgrp, "tcsetpgrp", 2, 0, 0, scm_tcsetpgrp); -SCM -scm_tcsetpgrp (port, pgid) - SCM port, pgid; -{ -#ifdef HAVE_TCSETPGRP - int fd; - SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcsetpgrp); - SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp); - fd = fileno ((FILE *)SCM_STREAM (port)); - if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1) - scm_syserror (s_tcsetpgrp); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_tcsetpgrp); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -/* Copy exec args from an SCM vector into a new C array. */ - -static char ** scm_convert_exec_args SCM_P ((SCM args)); - -static char ** -scm_convert_exec_args (args) - SCM args; -{ - char **execargv; - int num_args; - int i; - SCM_DEFER_INTS; - num_args = scm_ilength (args); - execargv = (char **) - scm_must_malloc ((num_args + 1) * sizeof (char *), s_ttyname); - for (i = 0; SCM_NNULLP (args); args = SCM_CDR (args), ++i) - { - scm_sizet len; - char *dst; - char *src; - SCM_ASSERT (SCM_NIMP (SCM_CAR (args)) && SCM_ROSTRINGP (SCM_CAR (args)), SCM_CAR (args), - "wrong type in SCM_ARG", "exec arg"); - len = 1 + SCM_ROLENGTH (SCM_CAR (args)); - dst = (char *) scm_must_malloc ((long) len, s_ttyname); - src = SCM_ROCHARS (SCM_CAR (args)); - while (len--) - dst[len] = src[len]; - execargv[i] = dst; - } - execargv[i] = 0; - SCM_ALLOW_INTS; - return execargv; -} - -SCM_PROC (s_execl, "execl", 0, 0, 1, scm_execl); - -SCM -scm_execl (args) - SCM args; -{ - char **execargv; - SCM filename = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_execl); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); - args = SCM_CDR (args); - execargv = scm_convert_exec_args (args); - execv (SCM_ROCHARS (filename), execargv); - scm_syserror (s_execl); - /* not reached. */ - return SCM_BOOL_F; -} - -SCM_PROC (s_execlp, "execlp", 0, 0, 1, scm_execlp); - -SCM -scm_execlp (args) - SCM args; -{ - char **execargv; - SCM filename = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_execlp); - if (SCM_SUBSTRP (filename)) - filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0); - args = SCM_CDR (args); - execargv = scm_convert_exec_args (args); - execvp (SCM_ROCHARS (filename), execargv); - scm_syserror (s_execlp); - /* not reached. */ - return SCM_BOOL_F; -} - -/* Flushing streams etc., is not done here. */ -SCM_PROC (s_fork, "fork", 0, 0, 0, scm_fork); - -SCM -scm_fork() -{ - int pid; - pid = fork (); - if (pid == -1) - scm_syserror (s_fork); - return SCM_MAKINUM (0L+pid); -} - - -SCM_PROC (s_uname, "uname", 0, 0, 0, scm_uname); - -SCM -scm_uname () -{ -#ifdef HAVE_UNAME - struct utsname buf; - SCM ans = scm_make_vector(SCM_MAKINUM(5), SCM_UNSPECIFIED, SCM_BOOL_F); - SCM *ve = SCM_VELTS (ans); - if (uname (&buf)) - return SCM_MAKINUM (errno); - ve[0] = scm_makfrom0str (buf.sysname); - ve[1] = scm_makfrom0str (buf.nodename); - ve[2] = scm_makfrom0str (buf.release); - ve[3] = scm_makfrom0str (buf.version); - ve[4] = scm_makfrom0str (buf.machine); -/* - a linux special? - ve[5] = scm_makfrom0str (buf.domainname); -*/ - return ans; -#else - scm_sysmissing (s_uname); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_environ, "environ", 0, 1, 0, scm_environ); - -SCM -scm_environ (env) - SCM env; -{ - if (SCM_UNBNDP (env)) - return scm_makfromstrs (-1, environ); - else - { - int num_strings; - char **new_environ; - int i = 0; - SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)), - env, SCM_ARG1, s_environ); - num_strings = scm_ilength (env); - new_environ = (char **) scm_must_malloc ((num_strings + 1) - * sizeof (char *), - s_environ); - while (SCM_NNULLP (env)) - { - int len; - char *src; - SCM_ASSERT (SCM_NIMP (SCM_CAR (env)) && SCM_ROSTRINGP (SCM_CAR (env)), env, SCM_ARG1, - s_environ); - len = 1 + SCM_ROLENGTH (SCM_CAR (env)); - new_environ[i] = scm_must_malloc ((long) len, s_environ); - src = SCM_ROCHARS (SCM_CAR (env)); - while (len--) - new_environ[i][len] = src[len]; - env = SCM_CDR (env); - i++; - } - new_environ[i] = 0; - /* Free the old environment, except when called for the first - * time. - */ - { - char **ep; - static int first = 1; - if (!first) - { - for (ep = environ; *ep != NULL; ep++) - scm_must_free (*ep); - scm_must_free ((char *) environ); - } - first = 0; - } - environ = new_environ; - return SCM_UNSPECIFIED; - } -} - -#ifdef L_tmpnam - -SCM_PROC (s_tmpnam, "tmpnam", 0, 0, 0, scm_tmpnam); - -SCM scm_tmpnam() -{ - char name[L_tmpnam]; - SCM_SYSCALL (tmpnam (name);); - return scm_makfrom0str (name); -} -#endif - -SCM_PROC (s_open_pipe, "open-pipe", 2, 0, 0, scm_open_pipe); - -SCM -scm_open_pipe (pipestr, modes) - SCM pipestr; - SCM modes; -{ - FILE *f; - register SCM z; - struct scm_port_table * pt; - - SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr, SCM_ARG1, s_open_pipe); - if (SCM_SUBSTRP (pipestr)) - pipestr = scm_makfromstr (SCM_ROCHARS (pipestr), SCM_ROLENGTH (pipestr), 0); - SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_pipe); - if (SCM_SUBSTRP (modes)) - modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0); - SCM_NEWCELL (z); - SCM_DEFER_INTS; - scm_ignore_signals (); - SCM_SYSCALL (f = popen (SCM_ROCHARS (pipestr), SCM_ROCHARS (modes))); - scm_unignore_signals (); - if (!f) - scm_syserror (s_open_pipe); - pt = scm_add_to_port_table (z); - SCM_SETPTAB_ENTRY (z, pt); - SCM_SETCAR (z, scm_tc16_pipe | SCM_OPN - | (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG)); - SCM_SETSTREAM (z, (SCM)f); - SCM_ALLOW_INTS; - return z; -} - - -SCM_PROC (s_open_input_pipe, "open-input-pipe", 1, 0, 0, scm_open_input_pipe); - -SCM -scm_open_input_pipe(pipestr) - SCM pipestr; -{ - return scm_open_pipe(pipestr, scm_makfromstr("r", (sizeof "r")-1, 0)); -} - -SCM_PROC (s_open_output_pipe, "open-output-pipe", 1, 0, 0, scm_open_output_pipe); - -SCM -scm_open_output_pipe(pipestr) - SCM pipestr; -{ - return scm_open_pipe(pipestr, scm_makfromstr("w", (sizeof "w")-1, 0)); -} - - -SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime); - -SCM -scm_utime (pathname, actime, modtime) - SCM pathname; - SCM actime; - SCM modtime; -{ - int rv; - struct utimbuf utm_tmp; - - SCM_ASSERT (SCM_NIMP (pathname) && SCM_STRINGP (pathname), pathname, SCM_ARG1, s_utime); - - if (SCM_UNBNDP (actime)) - SCM_SYSCALL (time (&utm_tmp.actime)); - else - utm_tmp.actime = scm_num2ulong (actime, (char *) SCM_ARG2, s_utime); - - if (SCM_UNBNDP (modtime)) - SCM_SYSCALL (time (&utm_tmp.modtime)); - else - utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_utime); - - SCM_SYSCALL (rv = utime (SCM_CHARS (pathname), &utm_tmp)); - if (rv != 0) - scm_syserror (s_utime); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_access, "access?", 2, 0, 0, scm_access); - -SCM -scm_access (path, how) - SCM path; - SCM how; -{ - int rv; - - SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_access); - if (SCM_SUBSTRP (path)) - path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); - SCM_ASSERT (SCM_INUMP (how), how, SCM_ARG2, s_access); - rv = access (SCM_ROCHARS (path), SCM_INUM (how)); - return rv ? SCM_BOOL_F : SCM_BOOL_T; -} - -SCM_PROC (s_getpid, "getpid", 0, 0, 0, scm_getpid); - -SCM -scm_getpid () -{ - return SCM_MAKINUM ((unsigned long) getpid ()); -} - -SCM_PROC (s_putenv, "putenv", 1, 0, 0, scm_putenv); - -SCM -scm_putenv (str) - SCM str; -{ -#ifdef HAVE_PUTENV - int rv; - - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_putenv); - rv = putenv (SCM_CHARS (str)); - if (rv < 0) - scm_syserror (s_putenv); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_putenv); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_read_line, "read-line", 0, 2, 0, scm_read_line); - -SCM -scm_read_line (port, include_terminator) - SCM port; - SCM include_terminator; -{ - register int c; - register int j = 0; - scm_sizet len = 30; - SCM tok_buf; - register char *p; - int include; - - tok_buf = scm_makstr ((long) len, 0); - p = SCM_CHARS (tok_buf); - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_line); - - if (SCM_UNBNDP (include_terminator)) - include = 0; - else - include = SCM_NFALSEP (include_terminator); - - if (EOF == (c = scm_gen_getc (port))) - return SCM_EOF_VAL; - while (1) - { - switch (c) - { - case SCM_LINE_INCREMENTORS: - if (j >= len) - { - p = scm_grow_tok_buf (&tok_buf); - len = SCM_LENGTH (tok_buf); - } - p[j++] = c; - /* fallthrough */ - case EOF: - if (len == j) - return tok_buf; - return scm_vector_set_length_x (tok_buf, (SCM) SCM_MAKINUM (j)); - - default: - if (j >= len) - { - p = scm_grow_tok_buf (&tok_buf); - len = SCM_LENGTH (tok_buf); - } - p[j++] = c; - c = scm_gen_getc (port); - break; - } - } -} - -SCM_PROC (s_read_line_x, "read-line!", 1, 1, 0, scm_read_line_x); - -SCM -scm_read_line_x (str, port) - SCM str; - SCM port; -{ - register int c; - register int j = 0; - register char *p; - scm_sizet len; - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_read_line_x); - p = SCM_CHARS (str); - len = SCM_LENGTH (str); - if SCM_UNBNDP - (port) port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_read_line_x); - c = scm_gen_getc (port); - if (EOF == c) - return SCM_EOF_VAL; - while (1) - { - switch (c) - { - case SCM_LINE_INCREMENTORS: - case EOF: - return SCM_MAKINUM (j); - default: - if (j >= len) - { - scm_gen_ungetc (c, port); - return SCM_BOOL_F; - } - p[j++] = c; - c = scm_gen_getc (port); - } - } -} - -SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line); - -SCM -scm_write_line (obj, port) - SCM obj; - SCM port; -{ - scm_display (obj, port); - return scm_newline (port); -} - -SCM_PROC (s_setlocale, "setlocale", 1, 1, 0, scm_setlocale); - -SCM -scm_setlocale (category, locale) - SCM category; - SCM locale; -{ -#ifdef HAVE_SETLOCALE - char *clocale; - char *rv; - - SCM_ASSERT (SCM_INUMP (category), category, SCM_ARG1, s_setlocale); - if (SCM_UNBNDP (locale)) - { - clocale = NULL; - } - else - { - SCM_ASSERT (SCM_NIMP (locale) && SCM_STRINGP (locale), locale, SCM_ARG2, s_setlocale); - clocale = SCM_CHARS (locale); - } - - rv = setlocale (SCM_INUM (category), clocale); - if (rv == NULL) - scm_syserror (s_setlocale); - return scm_makfrom0str (rv); -#else - scm_sysmissing (s_setlocale); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime); - -SCM -scm_strftime (format, stime) - SCM format; - SCM stime; -{ - struct tm t; - - char *tbuf; - int n; - int size = 50; - char *fmt; - int len; - - SCM_ASSERT (SCM_NIMP (format) && SCM_STRINGP (format), format, SCM_ARG1, s_strftime); - SCM_ASSERT (SCM_NIMP (stime) && SCM_VECTORP (stime) && scm_obj_length (stime) == 9, - stime, SCM_ARG2, s_strftime); - - fmt = SCM_ROCHARS (format); - len = SCM_ROLENGTH (format); - -#define tm_deref scm_num2long (SCM_VELTS (stime)[n++], (char *)SCM_ARG2, s_strftime) - n = 0; - t.tm_sec = tm_deref; - t.tm_min = tm_deref; - t.tm_hour = tm_deref; - t.tm_mday = tm_deref; - t.tm_mon = tm_deref; - t.tm_year = tm_deref; - /* not used by mktime. - t.tm_wday = tm_deref; - t.tm_yday = tm_deref; */ - t.tm_isdst = tm_deref; -#undef tm_deref - - /* fill in missing fields and set the timezone. */ - mktime (&t); - - tbuf = scm_must_malloc (size, s_strftime); - while ((len = strftime (tbuf, size, fmt, &t)) == size) - { - scm_must_free (tbuf); - size *= 2; - tbuf = scm_must_malloc (size, s_strftime); - } - return scm_makfromstr (tbuf, len, 0); -} - -SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime); - -SCM -scm_strptime (format, string) - SCM format; - SCM string; -{ -#ifdef HAVE_STRPTIME - SCM stime; - struct tm t; - - char *fmt, *str, *rest; - int n; - - SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, s_strptime); - if (SCM_SUBSTRP (format)) - format = scm_makfromstr (SCM_ROCHARS (format), SCM_ROLENGTH (format), 0); - SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2, s_strptime); - if (SCM_SUBSTRP (string)) - string = scm_makfromstr (SCM_ROCHARS (string), SCM_ROLENGTH (string), 0); - - fmt = SCM_CHARS (format); - str = SCM_CHARS (string); - - /* initialize the struct tm */ -#define tm_init(field) t.field = 0 - tm_init (tm_sec); - tm_init (tm_min); - tm_init (tm_hour); - tm_init (tm_mday); - tm_init (tm_mon); - tm_init (tm_year); - tm_init (tm_wday); - tm_init (tm_yday); - tm_init (tm_isdst); -#undef tm_init - - SCM_DEFER_INTS; - rest = strptime (str, fmt, &t); - SCM_ALLOW_INTS; - - if (rest == NULL) - scm_syserror (s_strptime); - - stime = scm_make_vector (SCM_MAKINUM (9), scm_long2num (0), SCM_UNDEFINED); - -#define stime_set(val) scm_vector_set_x (stime, SCM_MAKINUM (n++), scm_long2num (t.val)); - n = 0; - stime_set (tm_sec); - stime_set (tm_min); - stime_set (tm_hour); - stime_set (tm_mday); - stime_set (tm_mon); - stime_set (tm_year); - stime_set (tm_wday); - stime_set (tm_yday); - stime_set (tm_isdst); -#undef stime_set - - return scm_cons (stime, scm_makfrom0str (rest)); -#else - scm_sysmissing (s_strptime); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - -SCM_PROC (s_mknod, "mknod", 3, 0, 0, scm_mknod); - -SCM -scm_mknod(path, mode, dev) - SCM path; - SCM mode; - SCM dev; -{ -#ifdef HAVE_MKNOD - int val; - SCM_ASSERT(SCM_NIMP(path) && SCM_STRINGP(path), path, SCM_ARG1, s_mknod); - SCM_ASSERT(SCM_INUMP(mode), mode, SCM_ARG2, s_mknod); - SCM_ASSERT(SCM_INUMP(dev), dev, SCM_ARG3, s_mknod); - SCM_SYSCALL(val = mknod(SCM_CHARS(path), SCM_INUM(mode), SCM_INUM(dev))); - if (val != 0) - scm_syserror (s_mknod); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_mknod); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_nice, "nice", 1, 0, 0, scm_nice); - -SCM -scm_nice(incr) - SCM incr; -{ -#ifdef HAVE_NICE - SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_nice); - if (nice(SCM_INUM(incr)) != 0) - scm_syserror (s_nice); - return SCM_UNSPECIFIED; -#else - scm_sysmissing (s_nice); - /* not reached. */ - return SCM_BOOL_F; -#endif -} - - -SCM_PROC (s_sync, "sync", 0, 0, 0, scm_sync); - -SCM -scm_sync() -{ -#ifdef HAVE_SYNC - sync(); -#else - scm_sysmissing (s_sync); - /* not reached. */ -#endif - return SCM_BOOL_F; -} - - - - -void -scm_init_posix () -{ - scm_add_feature ("posix"); -#ifdef HAVE_GETEUID - scm_add_feature ("EIDs"); -#endif -#ifdef WAIT_ANY - scm_sysintern ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY)); -#endif -#ifdef WAIT_MYPGRP - scm_sysintern ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP)); -#endif -#ifdef WNOHANG - scm_sysintern ("WNOHANG", SCM_MAKINUM (WNOHANG)); -#endif -#ifdef WUNTRACED - scm_sysintern ("WUNTRACED", SCM_MAKINUM (WUNTRACED)); -#endif - -#ifdef EINTR - scm_sysintern ("EINTR", SCM_MAKINUM (EINTR)); -#endif - -#ifdef SIGHUP - scm_sysintern ("SIGHUP", SCM_MAKINUM (SIGHUP)); -#endif -#ifdef SIGINT - scm_sysintern ("SIGINT", SCM_MAKINUM (SIGINT)); -#endif -#ifdef SIGQUIT - scm_sysintern ("SIGQUIT", SCM_MAKINUM (SIGQUIT)); -#endif -#ifdef SIGILL - scm_sysintern ("SIGILL", SCM_MAKINUM (SIGILL)); -#endif -#ifdef SIGTRAP - scm_sysintern ("SIGTRAP", SCM_MAKINUM (SIGTRAP)); -#endif -#ifdef SIGABRT - scm_sysintern ("SIGABRT", SCM_MAKINUM (SIGABRT)); -#endif -#ifdef SIGIOT - scm_sysintern ("SIGIOT", SCM_MAKINUM (SIGIOT)); -#endif -#ifdef SIGBUS - scm_sysintern ("SIGBUS", SCM_MAKINUM (SIGBUS)); -#endif -#ifdef SIGFPE - scm_sysintern ("SIGFPE", SCM_MAKINUM (SIGFPE)); -#endif -#ifdef SIGKILL - scm_sysintern ("SIGKILL", SCM_MAKINUM (SIGKILL)); -#endif -#ifdef SIGUSR1 - scm_sysintern ("SIGUSR1", SCM_MAKINUM (SIGUSR1)); -#endif -#ifdef SIGSEGV - scm_sysintern ("SIGSEGV", SCM_MAKINUM (SIGSEGV)); -#endif -#ifdef SIGUSR2 - scm_sysintern ("SIGUSR2", SCM_MAKINUM (SIGUSR2)); -#endif -#ifdef SIGPIPE - scm_sysintern ("SIGPIPE", SCM_MAKINUM (SIGPIPE)); -#endif -#ifdef SIGALRM - scm_sysintern ("SIGALRM", SCM_MAKINUM (SIGALRM)); -#endif -#ifdef SIGTERM - scm_sysintern ("SIGTERM", SCM_MAKINUM (SIGTERM)); -#endif -#ifdef SIGSTKFLT - scm_sysintern ("SIGSTKFLT", SCM_MAKINUM (SIGSTKFLT)); -#endif -#ifdef SIGCHLD - scm_sysintern ("SIGCHLD", SCM_MAKINUM (SIGCHLD)); -#endif -#ifdef SIGCONT - scm_sysintern ("SIGCONT", SCM_MAKINUM (SIGCONT)); -#endif -#ifdef SIGSTOP - scm_sysintern ("SIGSTOP", SCM_MAKINUM (SIGSTOP)); -#endif -#ifdef SIGTSTP - scm_sysintern ("SIGTSTP", SCM_MAKINUM (SIGTSTP)); -#endif -#ifdef SIGTTIN - scm_sysintern ("SIGTTIN", SCM_MAKINUM (SIGTTIN)); -#endif -#ifdef SIGTTOU - scm_sysintern ("SIGTTOU", SCM_MAKINUM (SIGTTOU)); -#endif -#ifdef SIGIO - scm_sysintern ("SIGIO", SCM_MAKINUM (SIGIO)); -#endif -#ifdef SIGPOLL - scm_sysintern ("SIGPOLL", SCM_MAKINUM (SIGPOLL)); -#endif -#ifdef SIGURG - scm_sysintern ("SIGURG", SCM_MAKINUM (SIGURG)); -#endif -#ifdef SIGXCPU - scm_sysintern ("SIGXCPU", SCM_MAKINUM (SIGXCPU)); -#endif -#ifdef SIGXFSZ - scm_sysintern ("SIGXFSZ", SCM_MAKINUM (SIGXFSZ)); -#endif -#ifdef SIGVTALRM - scm_sysintern ("SIGVTALRM", SCM_MAKINUM (SIGVTALRM)); -#endif -#ifdef SIGPROF - scm_sysintern ("SIGPROF", SCM_MAKINUM (SIGPROF)); -#endif -#ifdef SIGWINCH - scm_sysintern ("SIGWINCH", SCM_MAKINUM (SIGWINCH)); -#endif -#ifdef SIGLOST - scm_sysintern ("SIGLOST", SCM_MAKINUM (SIGLOST)); -#endif -#ifdef SIGPWR - scm_sysintern ("SIGPWR", SCM_MAKINUM (SIGPWR)); -#endif - /* access() symbols. */ - scm_sysintern ("R_OK", SCM_MAKINUM (R_OK)); - scm_sysintern ("W_OK", SCM_MAKINUM (W_OK)); - scm_sysintern ("X_OK", SCM_MAKINUM (X_OK)); - scm_sysintern ("F_OK", SCM_MAKINUM (F_OK)); - -#ifdef LC_COLLATE - scm_sysintern ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE)); -#endif -#ifdef LC_CTYPE - scm_sysintern ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE)); -#endif -#ifdef LC_MONETARY - scm_sysintern ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY)); -#endif -#ifdef LC_NUMERIC - scm_sysintern ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC)); -#endif -#ifdef LC_TIME - scm_sysintern ("LC_TIME", SCM_MAKINUM (LC_TIME)); -#endif -#ifdef LC_MESSAGES - scm_sysintern ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES)); -#endif -#ifdef LC_ALL - scm_sysintern ("LC_ALL", SCM_MAKINUM (LC_ALL)); -#endif -#include "posix.x" -} diff --git a/libguile/posix.h b/libguile/posix.h deleted file mode 100644 index 1dd9eb52d..000000000 --- a/libguile/posix.h +++ /dev/null @@ -1,101 +0,0 @@ -/* classes: h_files */ - -#ifndef POSIXH -#define POSIXH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - -extern SCM scm_tcsetpgrp SCM_P ((SCM port, SCM pgid)); -extern SCM scm_tcgetpgrp SCM_P ((SCM port)); -extern SCM scm_ctermid SCM_P ((void)); -extern SCM scm_setsid SCM_P ((void)); -extern SCM scm_setpgid SCM_P ((SCM pid, SCM pgid)); -extern SCM scm_pipe SCM_P ((void)); -extern SCM scm_getgroups SCM_P ((void)); -extern SCM scm_getpgrp SCM_P ((void)); -extern SCM scm_getpwuid SCM_P ((SCM user)); -extern SCM scm_setpwent SCM_P ((SCM arg)); -extern SCM scm_getgrgid SCM_P ((SCM name)); -extern SCM scm_setgrent SCM_P ((SCM arg)); -extern SCM scm_kill SCM_P ((SCM pid, SCM sig)); -extern SCM scm_waitpid SCM_P ((SCM pid, SCM options)); -extern SCM scm_getppid SCM_P ((void)); -extern SCM scm_getuid SCM_P ((void)); -extern SCM scm_getgid SCM_P ((void)); -extern SCM scm_geteuid SCM_P ((void)); -extern SCM scm_getegid SCM_P ((void)); -extern SCM scm_setuid SCM_P ((SCM id)); -extern SCM scm_setgid SCM_P ((SCM id)); -extern SCM scm_seteuid SCM_P ((SCM id)); -extern SCM scm_setegid SCM_P ((SCM id)); -extern SCM scm_ttyname SCM_P ((SCM port)); -extern SCM scm_execl SCM_P ((SCM args)); -extern SCM scm_execlp SCM_P ((SCM args)); -extern SCM scm_fork SCM_P ((void)); -extern SCM scm_uname SCM_P ((void)); -extern SCM scm_environ SCM_P ((SCM env)); -extern SCM scm_open_pipe SCM_P ((SCM pipestr, SCM modes)); -extern SCM scm_open_input_pipe SCM_P ((SCM pipestr)); -extern SCM scm_open_output_pipe SCM_P ((SCM pipestr)); -extern SCM scm_utime SCM_P ((SCM pathname, SCM actime, SCM modtime)); -extern SCM scm_access SCM_P ((SCM path, SCM how)); -extern SCM scm_getpid SCM_P ((void)); -extern SCM scm_putenv SCM_P ((SCM str)); -extern SCM scm_read_line SCM_P ((SCM port, SCM include_terminator)); -extern SCM scm_read_line_x SCM_P ((SCM str, SCM port)); -extern SCM scm_write_line SCM_P ((SCM obj, SCM port)); -extern SCM scm_setlocale SCM_P ((SCM category, SCM locale)); -extern SCM scm_strftime SCM_P ((SCM format, SCM stime)); -extern SCM scm_strptime SCM_P ((SCM format, SCM string)); -extern SCM scm_mknod SCM_P ((SCM path, SCM mode, SCM dev)); -extern SCM scm_nice SCM_P ((SCM incr)); -extern SCM scm_sync SCM_P ((void)); -extern void scm_init_posix SCM_P ((void)); - -#endif /* POSIXH */ diff --git a/libguile/print.c b/libguile/print.c deleted file mode 100644 index adc70482c..000000000 --- a/libguile/print.c +++ /dev/null @@ -1,860 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "genio.h" -#include "mbstrings.h" -#include "smob.h" -#include "eval.h" -#include "procprop.h" -#include "read.h" -#include "weaks.h" -#include "unif.h" -#include "alist.h" -#include "struct.h" - -#include "print.h" - - -/* {Names of immediate symbols} - * - * This table must agree with the declarations in scm.h: {Immediate Symbols}. - */ - -char *scm_isymnames[] = -{ - /* This table must agree with the declarations */ - "#@and", - "#@begin", - "#@case", - "#@cond", - "#@do", - "#@if", - "#@lambda", - "#@let", - "#@let*", - "#@letrec", - "#@or", - "#@quote", - "#@set!", - "#@define", -#if 0 - "#@literal-variable-ref", - "#@literal-variable-set!", -#endif - "#@apply", - "#@call-with-current-continuation", - - /* user visible ISYMS */ - /* other keywords */ - /* Flags */ - - "#f", - "#t", - "#<undefined>", - "#<eof>", - "()", - "#<unspecified>" -}; - -scm_option scm_print_opts[] = { - { SCM_OPTION_SCM, "closure-hook", SCM_BOOL_F, - "Hook for printing closures." }, - { SCM_OPTION_BOOLEAN, "source", 0, - "Print closures with source." } -}; - -SCM_PROC (s_print_options, "print-options-interface", 0, 1, 0, scm_print_options); - -SCM -scm_print_options (setting) - SCM setting; -{ - SCM ans = scm_options (setting, - scm_print_opts, - SCM_N_PRINT_OPTIONS, - s_print_options); - return ans; -} - - -/* {Printing of Scheme Objects} - */ - -/* Detection of circular references. - * - * Due to other constraints in the implementation, this code has bad - * time complexity (O (depth * N)), The printer code will be - * completely rewritten before next release of Guile. The new code - * will be O(N). - */ -#define PUSH_REF(pstate, obj) \ -{ \ - pstate->ref_stack[pstate->top++] = (obj); \ - if (pstate->top == pstate->ceiling) \ - grow_ref_stack (pstate); \ -} - -#define ENTER_NESTED_DATA(pstate, obj, label) \ -{ \ - register int i; \ - for (i = 0; i < pstate->top; ++i) \ - if (pstate->ref_stack[i] == (obj)) \ - goto label; \ - if (pstate->fancyp) \ - { \ - if (pstate->top - pstate->list_offset >= pstate->level) \ - { \ - scm_gen_putc ('#', port); \ - return; \ - } \ - } \ - PUSH_REF(pstate, obj); \ -} \ - -#define EXIT_NESTED_DATA(pstate) { --pstate->top; } - -static SCM print_state_pool; - -#if 1 /* Used for debugging purposes */ -SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate); - -SCM -scm_current_pstate () -{ - return SCM_CADR (print_state_pool); -} -#endif - -#define PSTATE_SIZE 50L - -static SCM make_print_state SCM_P ((void)); - -static SCM -make_print_state () -{ - SCM print_state = scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */ - SCM_INUM0, - SCM_EOL); - scm_print_state *pstate = SCM_PRINT_STATE (print_state); - pstate->ref_vect = scm_make_vector (SCM_MAKINUM (PSTATE_SIZE), - SCM_UNDEFINED, - SCM_UNDEFINED); - pstate->ref_stack = SCM_VELTS (pstate->ref_vect); - pstate->ceiling = SCM_LENGTH (pstate->ref_vect); - return print_state; -} - -SCM -scm_make_print_state () -{ - SCM answer = 0; - - /* First try to allocate a print state from the pool */ - SCM_DEFER_INTS; - if (SCM_NNULLP (SCM_CDR (print_state_pool))) - { - answer = SCM_CADR (print_state_pool); - SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool)); - } - SCM_ALLOW_INTS; - - return answer ? answer : make_print_state (); -} - -void -scm_free_print_state (print_state) - SCM print_state; -{ - SCM handle; - scm_print_state *pstate = SCM_PRINT_STATE (print_state); - /* Cleanup before returning print state to pool. - * It is better to do it here. Doing it in scm_prin1 - * would cost more since that function is called much more - * often. - */ - pstate->fancyp = 0; - SCM_NEWCELL (handle); - SCM_DEFER_INTS; - SCM_SETCAR (handle, print_state); - SCM_SETCDR (handle, SCM_CDR (print_state_pool)); - SCM_SETCDR (print_state_pool, handle); - SCM_ALLOW_INTS; -} - -static void grow_ref_stack SCM_P ((scm_print_state *pstate)); - -static void -grow_ref_stack (pstate) - scm_print_state *pstate; -{ - int new_size = 2 * pstate->ceiling; - scm_vector_set_length_x (pstate->ref_vect, SCM_MAKINUM (new_size)); - pstate->ref_stack = SCM_VELTS (pstate->ref_vect); - pstate->ceiling = new_size; -} - - -static void print_circref SCM_P ((SCM port, scm_print_state *pstate, SCM ref)); - -static void -print_circref (port, pstate, ref) - SCM port; - scm_print_state *pstate; - SCM ref; -{ - register int i; - int self = pstate->top - 1; - i = pstate->top - 1; - if (SCM_CONSP (pstate->ref_stack[i])) - { - while (i > 0) - { - if (SCM_NCONSP (pstate->ref_stack[i - 1]) - || SCM_CDR (pstate->ref_stack[i - 1]) != pstate->ref_stack[i]) - break; - --i; - } - self = i; - } - for (i = pstate->top - 1; 1; --i) - if (pstate->ref_stack[i] == ref) - break; - scm_gen_putc ('#', port); - scm_intprint (i - self, 10, port); - scm_gen_putc ('#', port); -} - -/* Print generally. Handles both write and display according to PSTATE. - */ - - -void -scm_iprin1 (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - register long i; -taloop: - switch (7 & (int) exp) - { - case 2: - case 6: - scm_intprint (SCM_INUM (exp), 10, port); - break; - case 4: - if (SCM_ICHRP (exp)) - { - i = SCM_ICHR (exp); - scm_put_wchar (i, port, SCM_WRITINGP (pstate)); - - } - else if (SCM_IFLAGP (exp) - && (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *)))) - scm_gen_puts (scm_regular_string, SCM_ISYMCHARS (exp), port); - else if (SCM_ILOCP (exp)) - { - scm_gen_puts (scm_regular_string, "#@", port); - scm_intprint ((long) SCM_IFRAME (exp), 10, port); - scm_gen_putc (SCM_ICDRP (exp) ? '-' : '+', port); - scm_intprint ((long) SCM_IDIST (exp), 10, port); - } - else - goto idef; - break; - case 1: - /* gloc */ - scm_gen_puts (scm_regular_string, "#@", port); - exp = SCM_CAR (exp - 1); - goto taloop; - default: - idef: - scm_ipruk ("immediate", exp, port); - break; - case 0: - switch (SCM_TYP7 (exp)) - { - case scm_tcs_cons_gloc: - - if (SCM_CDR (SCM_CAR (exp) - 1L) == 0) - { - scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port); - scm_intprint(exp, 16, port); - scm_gen_putc ('>', port); - break; - } - - case scm_tcs_cons_imcar: - case scm_tcs_cons_nimcar: - ENTER_NESTED_DATA (pstate, exp, circref); - scm_iprlist ("(", exp, ')', port, pstate); - EXIT_NESTED_DATA (pstate); - break; - circref: - print_circref (port, pstate, exp); - break; - case scm_tcs_closures: - if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))) - { - SCM ans = scm_cons2 (exp, port, - scm_cons (SCM_WRITINGP (pstate) - ? SCM_BOOL_T - : SCM_BOOL_F, - SCM_EOL)); - ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL); - } - else - { - SCM name, code; - name = scm_procedure_property (exp, scm_i_name); - code = SCM_CODE (exp); - scm_gen_puts (scm_regular_string, "#<procedure ", port); - if (SCM_NIMP (name) && SCM_ROSTRINGP (name)) - { - scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port); - scm_gen_putc (' ', port); - } - scm_iprin1 (SCM_CAR (code), port, pstate); - if (SCM_PRINT_SOURCE_P) - { - code = scm_unmemocopy (SCM_CDR (code), - SCM_EXTEND_ENV (SCM_CAR (code), - SCM_EOL, - SCM_ENV (exp))); - ENTER_NESTED_DATA (pstate, exp, circref); - scm_iprlist (" ", code, '>', port, pstate); - EXIT_NESTED_DATA (pstate); - } - else - scm_gen_putc ('>', port); - } - break; - case scm_tc7_mb_string: - case scm_tc7_mb_substring: - scm_print_mb_string (exp, port, SCM_WRITINGP (pstate)); - break; - case scm_tc7_substring: - case scm_tc7_string: - if (SCM_WRITINGP (pstate)) - { - scm_gen_putc ('"', port); - for (i = 0; i < SCM_ROLENGTH (exp); ++i) - switch (SCM_ROCHARS (exp)[i]) - { - case '"': - case '\\': - scm_gen_putc ('\\', port); - default: - scm_gen_putc (SCM_ROCHARS (exp)[i], port); - } - scm_gen_putc ('"', port); - break; - } - else - scm_gen_write (scm_regular_string, SCM_ROCHARS (exp), - (scm_sizet) SCM_ROLENGTH (exp), - port); - break; - case scm_tcs_symbols: - if (SCM_MB_STRINGP (exp)) - { - scm_print_mb_symbol (exp, port); - break; - } - else - { - int pos; - int end; - int len; - char * str; - int weird; - int maybe_weird; - int mw_pos = 0; - - len = SCM_LENGTH (exp); - str = SCM_CHARS (exp); - scm_remember (&exp); - pos = 0; - weird = 0; - maybe_weird = 0; - - if (len == 0) - scm_gen_write (scm_regular_string, "#{}#", 4, port); - - for (end = pos; end < len; ++end) - switch (str[end]) - { -#ifdef BRACKETS_AS_PARENS - case '[': - case ']': -#endif - case '(': - case ')': - case '"': - case ';': - case SCM_WHITE_SPACES: - case SCM_LINE_INCREMENTORS: - weird_handler: - if (maybe_weird) - { - end = mw_pos; - maybe_weird = 0; - } - if (!weird) - { - scm_gen_write (scm_regular_string, "#{", 2, port); - weird = 1; - } - if (pos < end) - { - scm_gen_write (scm_regular_string, str + pos, end - pos, port); - } - { - char buf[2]; - buf[0] = '\\'; - buf[1] = str[end]; - scm_gen_write (scm_regular_string, buf, 2, port); - } - pos = end + 1; - break; - case '\\': - if (weird) - goto weird_handler; - if (!maybe_weird) - { - maybe_weird = 1; - mw_pos = pos; - } - break; - case '}': - case '#': - if (weird) - goto weird_handler; - break; - default: - break; - } - if (pos < end) - scm_gen_write (scm_regular_string, str + pos, end - pos, port); - if (weird) - scm_gen_write (scm_regular_string, "}#", 2, port); - break; - } - case scm_tc7_wvect: - ENTER_NESTED_DATA (pstate, exp, circref); - if (SCM_IS_WHVEC (exp)) - scm_gen_puts (scm_regular_string, "#wh(", port); - else - scm_gen_puts (scm_regular_string, "#w(", port); - goto common_vector_printer; - - case scm_tc7_vector: - ENTER_NESTED_DATA (pstate, exp, circref); - scm_gen_puts (scm_regular_string, "#(", port); - common_vector_printer: - for (i = 0; i + 1 < SCM_LENGTH (exp); ++i) - { - /* CHECK_INTS; */ - scm_iprin1 (SCM_VELTS (exp)[i], port, pstate); - scm_gen_putc (' ', port); - } - if (i < SCM_LENGTH (exp)) - { - /* CHECK_INTS; */ - scm_iprin1 (SCM_VELTS (exp)[i], port, pstate); - } - scm_gen_putc (')', port); - EXIT_NESTED_DATA (pstate); - break; - case scm_tc7_bvect: - case scm_tc7_byvect: - case scm_tc7_svect: - case scm_tc7_ivect: - case scm_tc7_uvect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - scm_raprin1 (exp, port, pstate); - break; - case scm_tcs_subrs: - scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port); - scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp)) - ? scm_mb_string - : scm_regular_string), - SCM_CHARS (SCM_SNAME (exp)), port); - scm_gen_putc ('>', port); - break; -#ifdef CCLO - case scm_tc7_cclo: - scm_gen_puts (scm_regular_string, "#<compiled-closure ", port); - scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate); - scm_gen_putc ('>', port); - break; -#endif - case scm_tc7_contin: - scm_gen_puts (scm_regular_string, "#<continuation ", port); - scm_intprint (SCM_LENGTH (exp), 10, port); - scm_gen_puts (scm_regular_string, " @ ", port); - scm_intprint ((long) SCM_CHARS (exp), 16, port); - scm_gen_putc ('>', port); - break; - case scm_tc7_port: - i = SCM_PTOBNUM (exp); - if (i < scm_numptob - && scm_ptobs[i].print - && (scm_ptobs[i].print) (exp, port, pstate)) - break; - goto punk; - case scm_tc7_smob: - ENTER_NESTED_DATA (pstate, exp, circref); - i = SCM_SMOBNUM (exp); - if (i < scm_numsmob && scm_smobs[i].print - && (scm_smobs[i].print) (exp, port, pstate)) - { - EXIT_NESTED_DATA (pstate); - break; - } - EXIT_NESTED_DATA (pstate); - default: - punk: - scm_ipruk ("type", exp, port); - } - } -} - -/* Print states are necessary for circular reference safe printing. - * They are also expensive to allocate. Therefore print states are - * kept in a pool so that they can be reused. - */ - -void -scm_prin1 (exp, port, writingp) - SCM exp; - SCM port; - int writingp; -{ - SCM handle = 0; /* Will GC protect the handle whilst unlinked */ - scm_print_state *pstate; - - /* First try to allocate a print state from the pool */ - SCM_DEFER_INTS; - if (SCM_NNULLP (SCM_CDR (print_state_pool))) - { - handle = SCM_CDR (print_state_pool); - SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool)); - } - SCM_ALLOW_INTS; - - if (!handle) - handle = scm_cons (make_print_state (), SCM_EOL); - - pstate = SCM_PRINT_STATE (SCM_CAR (handle)); - pstate->writingp = writingp; - scm_iprin1 (exp, port, pstate); - - /* Return print state to pool */ - SCM_DEFER_INTS; - SCM_SETCDR (handle, SCM_CDR (print_state_pool)); - SCM_SETCDR (print_state_pool, handle); - SCM_ALLOW_INTS; -} - - -/* Print an integer. - */ - -void -scm_intprint (n, radix, port) - long n; - int radix; - SCM port; -{ - char num_buf[SCM_INTBUFLEN]; - scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port); -} - -/* Print an object of unrecognized type. - */ - -void -scm_ipruk (hdr, ptr, port) - char *hdr; - SCM ptr; - SCM port; -{ - scm_gen_puts (scm_regular_string, "#<unknown-", port); - scm_gen_puts (scm_regular_string, hdr, port); - if (SCM_CELLP (ptr)) - { - scm_gen_puts (scm_regular_string, " (0x", port); - scm_intprint (SCM_CAR (ptr), 16, port); - scm_gen_puts (scm_regular_string, " . 0x", port); - scm_intprint (SCM_CDR (ptr), 16, port); - scm_gen_puts (scm_regular_string, ") @", port); - } - scm_gen_puts (scm_regular_string, " 0x", port); - scm_intprint (ptr, 16, port); - scm_gen_putc ('>', port); -} - -/* Print a list. - */ - - -void -scm_iprlist (hdr, exp, tlr, port, pstate) - char *hdr; - SCM exp; - char tlr; - SCM port; - scm_print_state *pstate; -{ - register int i; - register SCM hare, tortoise; - int floor = pstate->top - 2; - scm_gen_puts (scm_regular_string, hdr, port); - /* CHECK_INTS; */ - if (pstate->fancyp) - goto fancy_printing; - - /* Run a hare and tortoise so that total time complexity will be - O(depth * N) instead of O(N^2). */ - hare = SCM_CDR (exp); - tortoise = exp; - while (SCM_NIMP (hare) && SCM_ECONSP (hare)) - { - if (hare == tortoise) - goto fancy_printing; - hare = SCM_CDR (hare); - if (SCM_IMP (hare) || SCM_NECONSP (hare)) - break; - hare = SCM_CDR (hare); - tortoise = SCM_CDR (tortoise); - } - - /* No cdr cycles intrinsic to this list */ - scm_iprin1 (SCM_CAR (exp), port, pstate); - exp = SCM_CDR (exp); - for (; SCM_NIMP (exp); exp = SCM_CDR (exp)) - { - if (SCM_NECONSP (exp)) - break; - for (i = floor; i >= 0; --i) - if (pstate->ref_stack[i] == exp) - goto circref; - PUSH_REF (pstate, exp); - scm_gen_putc (' ', port); - /* CHECK_INTS; */ - scm_iprin1 (SCM_CAR (exp), port, pstate); - } - if (SCM_NNULLP (exp)) - { - scm_gen_puts (scm_regular_string, " . ", port); - scm_iprin1 (exp, port, pstate); - } - -end: - scm_gen_putc (tlr, port); - pstate->top = floor + 2; - return; - -fancy_printing: - { - int n = pstate->length; - - scm_iprin1 (SCM_CAR (exp), port, pstate); - exp = SCM_CDR (exp); --n; - for (; SCM_NIMP (exp); exp = SCM_CDR (exp)) - { - if (SCM_NECONSP (exp)) - break; - for (i = 0; i < pstate->top; ++i) - if (pstate->ref_stack[i] == exp) - goto fancy_circref; - if (pstate->fancyp) - { - if (n == 0) - { - scm_gen_puts (scm_regular_string, " ...", port); - goto skip_tail; - } - else - --n; - } - PUSH_REF(pstate, exp); - ++pstate->list_offset; - scm_gen_putc (' ', port); - /* CHECK_INTS; */ - scm_iprin1 (SCM_CAR (exp), port, pstate); - } - } - if (SCM_NNULLP (exp)) - { - scm_gen_puts (scm_regular_string, " . ", port); - scm_iprin1 (exp, port, pstate); - } -skip_tail: - pstate->list_offset -= pstate->top - floor - 2; - goto end; - -fancy_circref: - pstate->list_offset -= pstate->top - floor - 2; - -circref: - scm_gen_puts (scm_regular_string, " . ", port); - print_circref (port, pstate, exp); - goto end; -} - - - -SCM_PROC(s_write, "write", 1, 1, 0, scm_write); - -SCM -scm_write (obj, port) - SCM obj; - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write); - scm_prin1 (obj, port, 1); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE == errno) - scm_close_port (port); -# endif -#endif - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_display, "display", 1, 1, 0, scm_display); - -SCM -scm_display (obj, port) - SCM obj; - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display); - scm_prin1 (obj, port, 0); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE == errno) - scm_close_port (port); -# endif -#endif - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline); - -SCM -scm_newline (port) - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline); - scm_gen_putc ('\n', port); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE == errno) - scm_close_port (port); - else -# endif -#endif - if (port == scm_cur_outp) - scm_fflush (port); - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char); - -SCM -scm_write_char (chr, port) - SCM chr; - SCM port; -{ - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char); - SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char); - scm_gen_putc ((int) SCM_ICHR (chr), port); -#ifdef HAVE_PIPE -# ifdef EPIPE - if (EPIPE == errno) - scm_close_port (port); -# endif -#endif - return SCM_UNSPECIFIED; -} - - - - - -void -scm_init_print () -{ - SCM vtable, type; - scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); - vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr), SCM_INUM0, SCM_EOL); - type = scm_make_struct (vtable, - SCM_INUM0, - scm_cons (scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)), - SCM_EOL)); - print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL)); -#include "print.x" -} diff --git a/libguile/print.h b/libguile/print.h deleted file mode 100644 index cb326fb5b..000000000 --- a/libguile/print.h +++ /dev/null @@ -1,100 +0,0 @@ -/* classes: h_files */ - -#ifndef PRINTH -#define PRINTH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -#include "libguile/options.h" - -extern scm_option scm_print_opts[]; - -#define SCM_PRINT_CLOSURE ((SCM) scm_print_opts[0].val) -#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val) -#define SCM_N_PRINT_OPTIONS 2 - -/* State information passed around during printing. - */ -#define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj)) - -#define RESET_PRINT_STATE(pstate) \ -{ \ - pstate->list_offset = 0; \ - pstate->top = 0; \ -} - -#define SCM_WRITINGP(pstate) ((pstate)->writingp) -#define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); } - -#define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwpwuwuwuruopr" -typedef struct scm_print_state { - SCM handle; /* Struct handle */ - unsigned long writingp; /* Writing? */ - unsigned long fancyp; /* Fancy printing? */ - unsigned long level; /* Max level */ - unsigned long length; /* Max number of objects per level */ - SCM hot_ref; /* Hot reference */ - unsigned long list_offset; - unsigned long top; /* Top of reference stack */ - unsigned long ceiling; /* Max size of reference stack */ - SCM *ref_stack; /* Stack of references used during - circular reference detection */ - SCM ref_vect; -} scm_print_state; - -extern SCM scm_print_options SCM_P ((SCM setting)); -SCM scm_make_print_state SCM_P ((void)); -void scm_free_print_state SCM_P ((SCM print_state)); -extern void scm_intprint SCM_P ((long n, int radix, SCM port)); -extern void scm_ipruk SCM_P ((char *hdr, SCM ptr, SCM port)); -extern void scm_iprlist SCM_P ((char *hdr, SCM exp, char tlr, SCM port, scm_print_state *pstate)); -extern void scm_prin1 SCM_P ((SCM exp, SCM port, int writingp)); -extern void scm_iprin1 SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); -extern SCM scm_write SCM_P ((SCM obj, SCM port)); -extern SCM scm_display SCM_P ((SCM obj, SCM port)); -extern SCM scm_newline SCM_P ((SCM port)); -extern SCM scm_write_char SCM_P ((SCM chr, SCM port)); -extern void scm_init_print SCM_P ((void)); - -#endif /* PRINTH */ diff --git a/libguile/procprop.c b/libguile/procprop.c deleted file mode 100644 index 42ca7dbd9..000000000 --- a/libguile/procprop.c +++ /dev/null @@ -1,138 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "alist.h" -#include "eval.h" - -#include "procprop.h" - - -static SCM -scm_stand_in_scm_proc(proc) - SCM proc; -{ - SCM answer; - answer = scm_assoc (proc, scm_stand_in_procs); - if (answer == SCM_BOOL_F) - { - answer = scm_closure (scm_listify (SCM_EOL, SCM_BOOL_F, SCM_UNDEFINED), - SCM_EOL); - scm_stand_in_procs = scm_cons (scm_cons (proc, answer), - scm_stand_in_procs); - } - else - answer = SCM_CDR (answer); - return answer; -} - -SCM_PROC(s_procedure_properties, "procedure-properties", 1, 0, 0, scm_procedure_properties); - -SCM -scm_procedure_properties (proc) - SCM proc; -{ - SCM_ASSERT (scm_procedure_p (proc), proc, SCM_ARG1, s_procedure_properties); - if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc))) - proc = scm_stand_in_scm_proc(proc); - return SCM_PROCPROPS (proc); -} - -SCM_PROC(s_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, scm_set_procedure_properties_x); - -SCM -scm_set_procedure_properties_x (proc, new_val) - SCM proc; - SCM new_val; -{ - if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc))) - proc = scm_stand_in_scm_proc(proc); - SCM_ASSERT (SCM_NIMP (proc) && SCM_CLOSUREP (proc), proc, SCM_ARG1, s_set_procedure_properties_x); - SCM_SETPROCPROPS (proc, new_val); - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_procedure_property, "procedure-property", 2, 0, 0, scm_procedure_property); - -SCM -scm_procedure_property (p, k) - SCM p; - SCM k; -{ - SCM assoc; - if (!(SCM_NIMP (p) && SCM_CLOSUREP (p))) - p = scm_stand_in_scm_proc(p); - SCM_ASSERT (scm_procedure_p (p), p, SCM_ARG1, s_procedure_property); - assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p)); - return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F); -} - -SCM_PROC(s_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, scm_set_procedure_property_x); - -SCM -scm_set_procedure_property_x (p, k, v) - SCM p; - SCM k; - SCM v; -{ - SCM assoc; - if (!(SCM_NIMP (p) && SCM_CLOSUREP (p))) - p = scm_stand_in_scm_proc(p); - SCM_ASSERT (SCM_NIMP (p) && SCM_CLOSUREP (p), p, SCM_ARG1, s_set_procedure_property_x); - assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p)); - if (SCM_NIMP (assoc)) - SCM_SETCDR (assoc, v); - else - SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p))); - return SCM_UNSPECIFIED; -} - - - - -void -scm_init_procprop () -{ -#include "procprop.x" -} - diff --git a/libguile/procprop.h b/libguile/procprop.h deleted file mode 100644 index cac97edd1..000000000 --- a/libguile/procprop.h +++ /dev/null @@ -1,61 +0,0 @@ -/* classes: h_files */ - -#ifndef PROCPROPH -#define PROCPROPH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_i_name; - - - -extern SCM scm_procedure_properties SCM_P ((SCM proc)); -extern SCM scm_set_procedure_properties_x SCM_P ((SCM proc, SCM new_val)); -extern SCM scm_procedure_property SCM_P ((SCM p, SCM k)); -extern SCM scm_set_procedure_property_x SCM_P ((SCM p, SCM k, SCM v)); -extern void scm_init_procprop SCM_P ((void)); - -#endif /* PROCPROPH */ diff --git a/libguile/procs.c b/libguile/procs.c deleted file mode 100644 index a8ccd0979..000000000 --- a/libguile/procs.c +++ /dev/null @@ -1,199 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "procs.h" - - - -/* {Procedures} - */ - - -SCM -scm_make_subr_opt (name, type, fcn, set) - char *name; - int type; - SCM (*fcn) (); - int set; -{ - SCM symcell; - long tmp; - register SCM z; - symcell = scm_sysintern (name, SCM_UNDEFINED); - tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8); - if ((tmp >> 8) != ((SCM_CELLPTR) (SCM_CAR (symcell)) - scm_heap_org)) - tmp = 0; - SCM_NEWCELL (z); - SCM_SUBRF (z) = fcn; - SCM_SETCAR (z, tmp + type); - if (set) - SCM_SETCDR (symcell, z); - return z; -} - - - -SCM -scm_make_subr (name, type, fcn) - char *name; - int type; - SCM (*fcn) (); -{ - return scm_make_subr_opt (name, type, fcn, 1); -} - -#ifdef CCLO - -SCM -scm_makcclo (proc, len) - SCM proc; - long len; -{ - SCM s; - SCM_NEWCELL (s); - SCM_DEFER_INTS; - SCM_SETCHARS (s, scm_must_malloc (len * sizeof (SCM), "compiled-closure")); - SCM_SETLENGTH (s, len, scm_tc7_cclo); - while (--len) - SCM_VELTS (s)[len] = SCM_UNSPECIFIED; - SCM_CCLO_SUBR (s) = proc; - SCM_ALLOW_INTS; - return s; -} -#endif - - - -SCM_PROC(s_procedure_p, "procedure?", 1, 0, 0, scm_procedure_p); - -SCM -scm_procedure_p (obj) - SCM obj; -{ - if (SCM_NIMP (obj)) - switch (SCM_TYP7 (obj)) - { - case scm_tcs_closures: - case scm_tc7_contin: - case scm_tcs_subrs: -#ifdef CCLO - case scm_tc7_cclo: -#endif - return SCM_BOOL_T; - default: - return SCM_BOOL_F; - } - return SCM_BOOL_F; -} - -SCM_PROC(s_closure_p, "closure?", 1, 0, 0, scm_closure_p); - -SCM -scm_closure_p (obj) - SCM obj; -{ - if (SCM_NIMP (obj)) - switch (SCM_TYP7 (obj)) - { - case scm_tcs_closures: - return SCM_BOOL_T; - default: ; - } - return SCM_BOOL_F; -} - -#ifdef __STDC__ -SCM -scm_thunk_p (SCM obj) -#else -SCM -scm_thunk_p (obj) - SCM obj; -#endif -{ - if (SCM_NIMP (obj)) - switch (SCM_TYP7 (obj)) - { - case scm_tcs_closures: - if (SCM_NULLP (SCM_CAR (SCM_CODE (obj)))) - return SCM_BOOL_T; - case scm_tc7_subr_0: - case scm_tc7_subr_1o: - case scm_tc7_lsubr: - case scm_tc7_rpsubr: - case scm_tc7_asubr: -#ifdef CCLO - case scm_tc7_cclo: -#endif - return SCM_BOOL_T; - default: - ; - } - return SCM_BOOL_F; -} - - - -void -scm_init_iprocs(subra, type) - scm_iproc *subra; - int type; -{ - for(;subra->scm_string; subra++) - scm_make_subr(subra->scm_string, - type, - subra->cproc); -} - - - - - -void -scm_init_procs () -{ -#include "procs.x" -} - diff --git a/libguile/procs.h b/libguile/procs.h deleted file mode 100644 index 50345e784..000000000 --- a/libguile/procs.h +++ /dev/null @@ -1,103 +0,0 @@ -/* classes: h_files */ - -#ifndef PROCSH -#define PROCSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - -/* Subrs - */ - -typedef struct scm_subr -{ - long sname; - SCM (*cproc) (); -} scm_subr; - -typedef struct scm_iproc -{ - char *scm_string; - SCM (*cproc) (); -} scm_iproc; - -typedef struct scm_dsubr -{ - long sname; - double (*dproc) (); -} scm_dsubr; - -#define SCM_SNAME(x) ((SCM_CAR(x)>>8)?(SCM)(scm_heap_org+(SCM_CAR(x)>>8)):scm_nullstr) -#define SCM_SUBRF(x) (((scm_subr *)(SCM2PTR(x)))->cproc) -#define SCM_DSUBRF(x) (((scm_dsubr *)(SCM2PTR(x)))->dproc) -#define SCM_CCLO_SUBR(x) (SCM_VELTS(x)[0]) - -/* Closures - */ - -#define SCM_CLOSUREP(x) (SCM_TYP3(x)==scm_tc3_closure) -#define SCM_CLOSCAR(x) (SCM_CAR(x)-scm_tc3_closure) -#define SCM_CODE(x) SCM_CAR(SCM_CLOSCAR (x)) -#define SCM_PROCPROPS(x) SCM_CDR(SCM_CLOSCAR (x)) -#define SCM_SETPROCPROPS(x, p) SCM_SETCDR(SCM_CLOSCAR (x), p) -#define SCM_SETCODE(x, e) (SCM_SETCAR (x, scm_cons ((e), SCM_EOL) + scm_tc3_closure)) -#define SCM_ENV(x) SCM_CDR(x) -#define SCM_SETENV(x, e) SCM_SETCDR (x, e) -#define SCM_TOP_LEVEL(SCM_ENV) (SCM_NULLP(SCM_ENV) || (SCM_BOOL_T == scm_procedure_p (SCM_CAR (SCM_ENV)))) - - - -extern SCM scm_make_subr SCM_P ((char *name, int type, SCM (*fcn) ())); -extern SCM scm_make_subr_opt SCM_P ((char *name, int type, SCM (*fcn) (), - int set)); -extern SCM scm_makcclo SCM_P ((SCM proc, long len)); -extern SCM scm_procedure_p SCM_P ((SCM obj)); -extern SCM scm_thunk_p SCM_P ((SCM obj)); -extern void scm_init_iprocs SCM_P ((scm_iproc *subra, int type)); -extern void scm_init_procs SCM_P ((void)); - - -#endif /* PROCSH */ diff --git a/libguile/ramap.c b/libguile/ramap.c deleted file mode 100644 index a139566fc..000000000 --- a/libguile/ramap.c +++ /dev/null @@ -1,2127 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - - - -#include <stdio.h> -#include "_scm.h" -#include "unif.h" -#include "smob.h" -#include "chars.h" -#include "eq.h" -#include "eval.h" -#include "feature.h" - -#include "ramap.h" - - -#ifdef ARRAYS - -typedef struct -{ - char *name; - SCM sproc; - int (*vproc) (); -} ra_iproc; - -static ra_iproc ra_rpsubrs[]; -static ra_iproc ra_asubrs[]; - -#define BVE_REF(a, i) ((SCM_VELTS(a)[(i)/SCM_LONG_BIT] & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0) -#define BVE_SET(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] |= (1L<<((i)%SCM_LONG_BIT))) -#define BVE_CLR(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] &= ~(1L<<((i)%SCM_LONG_BIT))) - -/* Fast, recycling scm_vector ref */ -#define RVREF(ra, i, e) (e = scm_cvref(ra, i, e)) - -/* #define RVREF(ra, i, e) (scm_cvref(ra, i, SCM_UNDEFINED)) to turn off */ - -/* IVDEP means "ignore scm_vector dependencies", meaning we guarantee that - elements of scm_vector operands are not aliased */ -#ifdef _UNICOS -#define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line} -#else -#define IVDEP(test, line) line -#endif - - - -/* inds must be a uvect or ivect, no check. */ - - -static scm_sizet cind SCM_P ((SCM ra, SCM inds)); - -static scm_sizet -cind (ra, inds) - SCM ra; - SCM inds; -{ - scm_sizet i; - int k; - long *ve = SCM_VELTS (inds); - if (!SCM_ARRAYP (ra)) - return *ve; - i = SCM_ARRAY_BASE (ra); - for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) - i += (ve[k] - SCM_ARRAY_DIMS (ra)[k].lbnd) * SCM_ARRAY_DIMS (ra)[k].inc; - return i; -} - - -/* Checker for scm_array mapping functions: - return values: 4 --> shapes, increments, and bases are the same; - 3 --> shapes and increments are the same; - 2 --> shapes are the same; - 1 --> ras are at least as big as ra0; - 0 --> no match. - */ - -int -scm_ra_matchp (ra0, ras) - SCM ra0; - SCM ras; -{ - SCM ra1; - scm_array_dim dims; - scm_array_dim *s0 = &dims; - scm_array_dim *s1; - scm_sizet bas0 = 0; - int i, ndim = 1; - int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */ - if SCM_IMP - (ra0) return 0; - switch (SCM_TYP7 (ra0)) - { - default: - return 0; - case scm_tc7_vector: - case scm_tc7_string: - case scm_tc7_bvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - s0->lbnd = 0; - s0->inc = 1; - s0->ubnd = (long) SCM_LENGTH (ra0) - 1; - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra0)) - return 0; - ndim = SCM_ARRAY_NDIM (ra0); - s0 = SCM_ARRAY_DIMS (ra0); - bas0 = SCM_ARRAY_BASE (ra0); - break; - } - while SCM_NIMP - (ras) - { - ra1 = SCM_CAR (ras); - if SCM_IMP - (ra1) return 0; - switch SCM_TYP7 - (ra1) - { - default: - return 0; - case scm_tc7_vector: - case scm_tc7_string: - case scm_tc7_bvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - if (1 != ndim) - return 0; - switch (exact) - { - case 4: - if (0 != bas0) - exact = 3; - case 3: - if (1 != s0->inc) - exact = 2; - case 2: - if ((0 == s0->lbnd) && (s0->ubnd == SCM_LENGTH (ra1) - 1)) - break; - exact = 1; - case 1: - if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1)) - return 0; - } - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1)) - return 0; - s1 = SCM_ARRAY_DIMS (ra1); - if (bas0 != SCM_ARRAY_BASE (ra1)) - exact = 3; - for (i = 0; i < ndim; i++) - switch (exact) - { - case 4: - case 3: - if (s0[i].inc != s1[i].inc) - exact = 2; - case 2: - if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd) - break; - exact = 1; - default: - if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd) - return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1); - } - break; - } - ras = SCM_CDR (ras); - } - return exact; -} - -static char s_ra_mismatch[] = "array shape mismatch"; - -int -scm_ramapc (cproc, data, ra0, lra, what) - int (*cproc) (); - SCM data; - SCM ra0; - SCM lra; - char *what; -{ - SCM inds, z; - SCM vra0, ra1, vra1; - SCM lvra, *plvra; - long *vinds; - int k, kmax; - switch (scm_ra_matchp (ra0, lra)) - { - default: - case 0: - scm_wta (ra0, s_ra_mismatch, what); - case 2: - case 3: - case 4: /* Try unrolling arrays */ - kmax = (SCM_ARRAYP (ra0) ? SCM_ARRAY_NDIM (ra0) - 1 : 0); - if (kmax < 0) - goto gencase; - vra0 = scm_array_contents (ra0, SCM_UNDEFINED); - if SCM_IMP - (vra0) goto gencase; - if (!SCM_ARRAYP (vra0)) - { - vra1 = scm_make_ra (1); - SCM_ARRAY_BASE (vra1) = 0; - SCM_ARRAY_DIMS (vra1)->lbnd = 0; - SCM_ARRAY_DIMS (vra1)->ubnd = SCM_LENGTH (vra0) - 1; - SCM_ARRAY_DIMS (vra1)->inc = 1; - SCM_ARRAY_V (vra1) = vra0; - vra0 = vra1; - } - lvra = SCM_EOL; - plvra = &lvra; - for (z = lra; SCM_NIMP (z); z = SCM_CDR (z)) - { - ra1 = SCM_CAR (z); - vra1 = scm_make_ra (1); - SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd; - SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd; - if (!SCM_ARRAYP (ra1)) - { - SCM_ARRAY_BASE (vra1) = 0; - SCM_ARRAY_DIMS (vra1)->inc = 1; - SCM_ARRAY_V (vra1) = ra1; - } - else if (!SCM_ARRAY_CONTP (ra1)) - goto gencase; - else - { - SCM_ARRAY_BASE (vra1) = SCM_ARRAY_BASE (ra1); - SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc; - SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1); - } - *plvra = scm_cons (vra1, SCM_EOL); - plvra = SCM_CDRLOC (*plvra); - } - return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)); - case 1: - gencase: /* Have to loop over all dimensions. */ - vra0 = scm_make_ra (1); - if SCM_ARRAYP - (ra0) - { - kmax = SCM_ARRAY_NDIM (ra0) - 1; - if (kmax < 0) - { - SCM_ARRAY_DIMS (vra0)->lbnd = 0; - SCM_ARRAY_DIMS (vra0)->ubnd = 0; - SCM_ARRAY_DIMS (vra0)->inc = 1; - } - else - { - SCM_ARRAY_DIMS (vra0)->lbnd = SCM_ARRAY_DIMS (ra0)[kmax].lbnd; - SCM_ARRAY_DIMS (vra0)->ubnd = SCM_ARRAY_DIMS (ra0)[kmax].ubnd; - SCM_ARRAY_DIMS (vra0)->inc = SCM_ARRAY_DIMS (ra0)[kmax].inc; - } - SCM_ARRAY_BASE (vra0) = SCM_ARRAY_BASE (ra0); - SCM_ARRAY_V (vra0) = SCM_ARRAY_V (ra0); - } - else - { - kmax = 0; - SCM_ARRAY_DIMS (vra0)->lbnd = 0; - SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1; - SCM_ARRAY_DIMS (vra0)->inc = 1; - SCM_ARRAY_BASE (vra0) = 0; - SCM_ARRAY_V (vra0) = ra0; - ra0 = vra0; - } - lvra = SCM_EOL; - plvra = &lvra; - for (z = lra; SCM_NIMP (z); z = SCM_CDR (z)) - { - ra1 = SCM_CAR (z); - vra1 = scm_make_ra (1); - SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd; - SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd; - if SCM_ARRAYP - (ra1) - { - if (kmax >= 0) - SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc; - SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1); - } - else - { - SCM_ARRAY_DIMS (vra1)->inc = 1; - SCM_ARRAY_V (vra1) = ra1; - } - *plvra = scm_cons (vra1, SCM_EOL); - plvra = SCM_CDRLOC (*plvra); - } - inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L)); - vinds = (long *) SCM_VELTS (inds); - for (k = 0; k <= kmax; k++) - vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd; - k = kmax; - do - { - if (k == kmax) - { - SCM y = lra; - SCM_ARRAY_BASE (vra0) = cind (ra0, inds); - for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y)) - SCM_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), inds); - if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra))) - return 0; - k--; - continue; - } - if (vinds[k] < SCM_ARRAY_DIMS (ra0)[k].ubnd) - { - vinds[k]++; - k++; - continue; - } - vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd - 1; - k--; - } - while (k >= 0); - return 1; - } -} - - -static char s_array_fill_x[]; - -int -scm_array_fill_int (ra, fill, ignore) - SCM ra; - SCM fill; - SCM ignore; -{ - scm_sizet i, n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1; - long inc = SCM_ARRAY_DIMS (ra)->inc; - scm_sizet base = SCM_ARRAY_BASE (ra); - ra = SCM_ARRAY_V (ra); - switch SCM_TYP7 - (ra) - { - default: - for (i = base; n--; i += inc) - scm_array_set_x (ra, fill, SCM_MAKINUM (i)); - break; - case scm_tc7_vector: - for (i = base; n--; i += inc) - SCM_VELTS (ra)[i] = fill; - break; - case scm_tc7_string: - SCM_ASRTGO (SCM_ICHRP (fill), badarg2); - for (i = base; n--; i += inc) - SCM_CHARS (ra)[i] = SCM_ICHR (fill); - break; - case scm_tc7_bvect: - { - long *ve = (long *) SCM_VELTS (ra); - if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_LENGTH (ra))) - { - i = base / SCM_LONG_BIT; - if (SCM_BOOL_F == fill) - { - if (base % SCM_LONG_BIT) /* leading partial word */ - ve[i++] &= ~(~0L << (base % SCM_LONG_BIT)); - for (; i < (base + n) / SCM_LONG_BIT; i++) - ve[i] = 0L; - if ((base + n) % SCM_LONG_BIT) /* trailing partial word */ - ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT)); - } - else if (SCM_BOOL_T == fill) - { - if (base % SCM_LONG_BIT) - ve[i++] |= ~0L << (base % SCM_LONG_BIT); - for (; i < (base + n) / SCM_LONG_BIT; i++) - ve[i] = ~0L; - if ((base + n) % SCM_LONG_BIT) - ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT)); - } - else - badarg2:scm_wta (fill, (char *) SCM_ARG2, s_array_fill_x); - } - else - { - if (SCM_BOOL_F == fill) - for (i = base; n--; i += inc) - ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT)); - else if (SCM_BOOL_T == fill) - for (i = base; n--; i += inc) - ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT)); - else - goto badarg2; - } - break; - } - case scm_tc7_uvect: - SCM_ASRTGO (0 <= SCM_INUM (fill), badarg2); - case scm_tc7_ivect: - SCM_ASRTGO (SCM_INUMP (fill), badarg2); - { - long f = SCM_INUM (fill), *ve = (long *) SCM_VELTS (ra); - for (i = base; n--; i += inc) - ve[i] = f; - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float f, *ve = (float *) SCM_VELTS (ra); - SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2); - f = SCM_REALPART (fill); - for (i = base; n--; i += inc) - ve[i] = f; - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double f, *ve = (double *) SCM_VELTS (ra); - SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2); - f = SCM_REALPART (fill); - for (i = base; n--; i += inc) - ve[i] = f; - break; - } - case scm_tc7_cvect: - { - double fr, fi; - double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra); - SCM_ASRTGO (SCM_NIMP (fill) && SCM_INEXP (fill), badarg2); - fr = SCM_REALPART (fill); - fi = (SCM_CPLXP (fill) ? SCM_IMAG (fill) : 0.0); - for (i = base; n--; i += inc) - { - ve[i][0] = fr; - ve[i][1] = fi; - } - break; - } -#endif /* SCM_FLOATS */ - } - return 1; -} - -SCM_PROC(s_array_fill_x, "array-fill!", 2, 0, 0, scm_array_fill_x); - -SCM -scm_array_fill_x (ra, fill) - SCM ra; - SCM fill; -{ - scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, s_array_fill_x); - return SCM_UNSPECIFIED; -} - - - - -static int racp SCM_P ((SCM dst, SCM src)); - -static int -racp (src, dst) - SCM dst; - SCM src; -{ - long n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1); - long inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc; - scm_sizet i_d, i_s = SCM_ARRAY_BASE (src); - dst = SCM_CAR (dst); - inc_d = SCM_ARRAY_DIMS (dst)->inc; - i_d = SCM_ARRAY_BASE (dst); - src = SCM_ARRAY_V (src); - dst = SCM_ARRAY_V (dst); - switch SCM_TYP7 - (dst) - { - default: - gencase: case scm_tc7_vector: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d)); - break; - case scm_tc7_string: - if (scm_tc7_string != SCM_TYP7 (dst)) - goto gencase; - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - SCM_CHARS (dst)[i_d] = SCM_CHARS (src)[i_s]; - break; - case scm_tc7_bvect: - if (scm_tc7_bvect != SCM_TYP7 (dst)) - goto gencase; - if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT) - { - long *sv = (long *) SCM_VELTS (src); - long *dv = (long *) SCM_VELTS (dst); - sv += i_s / SCM_LONG_BIT; - dv += i_d / SCM_LONG_BIT; - if (i_s % SCM_LONG_BIT) - { /* leading partial word */ - *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT))); - dv++; - sv++; - n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT); - } - IVDEP (src != dst, - for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++) - * dv = *sv;) - if (n) /* trailing partial word */ - *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n)); - } - else - { - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - if (SCM_VELTS (src)[i_s / SCM_LONG_BIT] & (1L << (i_s % SCM_LONG_BIT))) - SCM_VELTS (dst)[i_d / SCM_LONG_BIT] |= (1L << (i_d % SCM_LONG_BIT)); - else - SCM_VELTS (dst)[i_d / SCM_LONG_BIT] &= ~(1L << (i_d % SCM_LONG_BIT)); - } - break; - case scm_tc7_uvect: - if (scm_tc7_uvect != SCM_TYP7 (src)) - goto gencase; - else - { - long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src); - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) - break; - } - case scm_tc7_ivect: - if (scm_tc7_uvect != SCM_TYP7 (src) && scm_tc7_ivect != SCM_TYP7 (src)) - goto gencase; - else - { - long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src); - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *d = (float *) SCM_VELTS (dst); - float *s = (float *) SCM_VELTS (src); - switch SCM_TYP7 - (src) - { - default: - goto gencase; - case scm_tc7_ivect: - case scm_tc7_uvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((long *) s)[i_s];) - break; - case scm_tc7_fvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) - break; - case scm_tc7_dvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((double *) s)[i_s];) - break; - } - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *d = (double *) SCM_VELTS (dst); - double *s = (double *) SCM_VELTS (src); - switch SCM_TYP7 - (src) - { - default: - goto gencase; - case scm_tc7_ivect: - case scm_tc7_uvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((long *) s)[i_s];) - break; - case scm_tc7_fvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((float *) s)[i_s];) - break; - case scm_tc7_dvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) - break; - } - break; - } - case scm_tc7_cvect: - { - double (*d)[2] = (double (*)[2]) SCM_VELTS (dst); - double (*s)[2] = (double (*)[2]) SCM_VELTS (src); - switch SCM_TYP7 - (src) - { - default: - goto gencase; - case scm_tc7_ivect: - case scm_tc7_uvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((long *) s)[i_s]; - d[i_d][1] = 0.0; - } - ) - break; - case scm_tc7_fvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((float *) s)[i_s]; - d[i_d][1] = 0.0; - } - ) - break; - case scm_tc7_dvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((double *) s)[i_s]; - d[i_d][1] = 0.0; - } - ) - break; - case scm_tc7_cvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = s[i_s][0]; - d[i_d][1] = s[i_s][1]; - } - ) - } - break; - } - } -#endif /* SCM_FLOATS */ - return 1; -} - - -SCM_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x); -SCM_PROC(s_array_copy_x, "array-copy!", 2, 0, 0, scm_array_copy_x); - -SCM -scm_array_copy_x (src, dst) - SCM src; - SCM dst; -{ - scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), s_array_copy_x); - return SCM_UNSPECIFIED; -} - -/* Functions callable by ARRAY-MAP! */ - - -int -scm_ra_eqp (ra0, ras) - SCM ra0; - SCM ras; -{ - SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - ra2 = SCM_ARRAY_V (ra2); - switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0) - { - default: - { - SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if SCM_FALSEP - (scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) - BVE_CLR (ra0, i0); - break; - } - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2]) - BVE_CLR (ra0, i0); - break; -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); - break; -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); - break; - case scm_tc7_cvect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] || - ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1]) - BVE_CLR (ra0, i0); - break; -#endif /*SCM_FLOATS*/ - } - return 1; -} - -/* opt 0 means <, nonzero means >= */ - -static int ra_compare SCM_P ((SCM ra0, SCM ra1, SCM ra2, int opt)); - -static int -ra_compare (ra0, ra1, ra2, opt) - SCM ra0; - SCM ra1; - SCM ra2; - int opt; -{ - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - ra2 = SCM_ARRAY_V (ra2); - switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0) - { - default: - { - SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (opt ? - SCM_NFALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) : - SCM_FALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) - BVE_CLR (ra0, i0); - break; - } - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - { - if BVE_REF - (ra0, i0) - if (opt ? - SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] : - SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2]) - BVE_CLR (ra0, i0); - } - break; -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (opt ? - ((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] : - ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); - break; -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if (opt ? - ((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] : - ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); - break; -#endif /*SCM_FLOATS*/ - } - return 1; -} - - - -int -scm_ra_lessp (ra0, ras) - SCM ra0; - SCM ras; -{ - return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0); -} - - -int -scm_ra_leqp (ra0, ras) - SCM ra0; - SCM ras; -{ - return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1); -} - - -int -scm_ra_grp (ra0, ras) - SCM ra0; - SCM ras; -{ - return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0); -} - - -int -scm_ra_greqp (ra0, ras) - SCM ra0; - SCM ras; -{ - return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1); -} - - - -int -scm_ra_sum (ra0, ras) - SCM ra0; - SCM ras; -{ - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NNULLP - (ras) - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_MAKINUM (i0)); - break; - } - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *v0 = SCM_VELTS (ra0); - long *v1 = SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] += v1[i1];) - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] += v1[i1];) - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] += v1[i1];) - break; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - v0[i0][0] += v1[i1][0]; - v0[i0][1] += v1[i1][1]; - } - ); - break; - } -#endif /* SCM_FLOATS */ - } - } - return 1; -} - - - -int -scm_ra_difference (ra0, ras) - SCM ra0; - SCM ras; -{ - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NULLP - (ras) - { - switch SCM_TYP7 - (ra0) - { - default: - { - SCM e0 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0) - scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = -v0[i0]; - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = -v0[i0]; - break; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - { - v0[i0][0] = -v0[i0][0]; - v0[i0][1] = -v0[i0][1]; - } - break; - } -#endif /* SCM_FLOATS */ - } - } - else - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0)); - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] -= v1[i1];) - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] -= v1[i1];) - break; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - v0[i0][0] -= v1[i1][0]; - v0[i0][1] -= v1[i1][1]; - } - ) - break; - } -#endif /* SCM_FLOATS */ - } - } - return 1; -} - - - -int -scm_ra_product (ra0, ras) - SCM ra0; - SCM ras; -{ - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NNULLP - (ras) - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_MAKINUM (i0)); - break; - } - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *v0 = SCM_VELTS (ra0); - long *v1 = SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] *= v1[i1];) - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] *= v1[i1];) - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] *= v1[i1];) - break; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - register double r; - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - r = v0[i0][0] * v1[i1][0] - v0[i0][1] * v1[i1][1]; - v0[i0][1] = v0[i0][0] * v1[i1][1] + v0[i0][1] * v1[i1][0]; - v0[i0][0] = r; - } - ); - break; - } -#endif /* SCM_FLOATS */ - } - } - return 1; -} - - -int -scm_ra_divide (ra0, ras) - SCM ra0; - SCM ras; -{ - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NULLP - (ras) - { - switch SCM_TYP7 - (ra0) - { - default: - { - SCM e0 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0) - scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = 1.0 / v0[i0]; - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = 1.0 / v0[i0]; - break; - } - case scm_tc7_cvect: - { - register double d; - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - { - d = v0[i0][0] * v0[i0][0] + v0[i0][1] * v0[i0][1]; - v0[i0][0] /= d; - v0[i0][1] /= -d; - } - break; - } -#endif /* SCM_FLOATS */ - } - } - else - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0)); - break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] /= v1[i1];) - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] /= v1[i1];) - break; - } - case scm_tc7_cvect: - { - register double d, r; - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - d = v1[i1][0] * v1[i1][0] + v1[i1][1] * v1[i1][1]; - r = (v0[i0][0] * v1[i1][0] + v0[i0][1] * v1[i1][1]) / d; - v0[i0][1] = (v0[i0][1] * v1[i1][0] - v0[i0][0] * v1[i1][1]) / d; - v0[i0][0] = r; - } - ) - break; - } -#endif /* SCM_FLOATS */ - } - } - return 1; -} - - -int -scm_array_identity (dst, src) - SCM src; - SCM dst; -{ - return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL)); -} - - - -static int ramap SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - long i = SCM_ARRAY_DIMS (ra0)->lbnd; - long inc = SCM_ARRAY_DIMS (ra0)->inc; - long n = SCM_ARRAY_DIMS (ra0)->ubnd; - long base = SCM_ARRAY_BASE (ra0) - i * inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NULLP - (ras) - for (; i <= n; i++) - scm_array_set_x (ra0, scm_apply (proc, SCM_EOL, SCM_EOL), SCM_MAKINUM (i * inc + base)); - else - { - SCM ra1 = SCM_CAR (ras); - SCM args, *ve = &ras; - scm_sizet k, i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - ras = SCM_CDR (ras); - if SCM_NULLP - (ras) - ras = scm_nullvect; - else - { - ras = scm_vector (ras); - ve = SCM_VELTS (ras); - } - for (; i <= n; i++, i1 += inc1) - { - args = SCM_EOL; - for (k = SCM_LENGTH (ras); k--;) - args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args); - args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args); - scm_array_set_x (ra0, scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i * inc + base)); - } - } - return 1; -} - - -static int ramap_cxr SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap_cxr (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - SCM ra1 = SCM_CAR (ras); - SCM e1 = SCM_UNDEFINED; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra1)->lbnd + 1; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - switch SCM_TYP7 - (ra0) - { - default: - gencase: - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0)); - break; -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *dst = (float *) SCM_VELTS (ra0); - switch SCM_TYP7 - (ra1) - { - default: - goto gencase; - case scm_tc7_fvect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) ((double) ((float *) SCM_VELTS (ra1))[i1]); - break; - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]); - break; - } - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *dst = (double *) SCM_VELTS (ra0); - switch SCM_TYP7 - (ra1) - { - default: - goto gencase; - case scm_tc7_dvect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) (((double *) SCM_VELTS (ra1))[i1]); - break; - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]); - break; - } - break; - } -#endif /* SCM_FLOATS */ - } - return 1; -} - - - -static int ramap_rp SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap_rp (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); - SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - ra2 = SCM_ARRAY_V (ra2); - switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0) - { - default: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - if SCM_FALSEP - (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) - BVE_CLR (ra0, i0); - break; - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - { - if SCM_FALSEP - (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]), - SCM_MAKINUM (SCM_VELTS (ra2)[i2]))) - BVE_CLR (ra0, i0); - } - break; -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - SCM a1 = scm_makflo (1.0), a2 = scm_makflo (1.0); - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - { - SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1]; - SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2]; - if SCM_FALSEP - (SCM_SUBRF (proc) (a1, a2)) - BVE_CLR (ra0, i0); - } - break; - } -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - { - SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0); - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - { - SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1]; - SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2]; - if SCM_FALSEP - (SCM_SUBRF (proc) (a1, a2)) - BVE_CLR (ra0, i0); - } - break; - } - case scm_tc7_cvect: - { - SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0); - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if BVE_REF - (ra0, i0) - { - SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1]; - SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1]; - SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2]; - SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1]; - if SCM_FALSEP - (SCM_SUBRF (proc) (a1, a2)) - BVE_CLR (ra0, i0); - } - break; - } -#endif /*SCM_FLOATS*/ - } - return 1; -} - - - -static int ramap_1 SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap_1 (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - SCM ra1 = SCM_CAR (ras); - SCM e1 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - if (scm_tc7_vector == SCM_TYP7 (ra0)) - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)), SCM_MAKINUM (i0)); - else - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1)), SCM_MAKINUM (i0)); - return 1; -} - - - -static int ramap_2o SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap_2o (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - SCM ra1 = SCM_CAR (ras); - SCM e1 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra0 = SCM_ARRAY_V (ra0); - ra1 = SCM_ARRAY_V (ra1); - ras = SCM_CDR (ras); - if SCM_NULLP - (ras) - { - if (scm_tc7_vector == SCM_TYP7 (ra0)) - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED), - SCM_MAKINUM (i0)); - else - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED), - SCM_MAKINUM (i0)); - } - else - { - SCM ra2 = SCM_CAR (ras); - SCM e2 = SCM_UNDEFINED; - scm_sizet i2 = SCM_ARRAY_BASE (ra2); - long inc2 = SCM_ARRAY_DIMS (ra2)->inc; - ra2 = SCM_ARRAY_V (ra2); - if (scm_tc7_vector == SCM_TYP7 (ra0)) - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - scm_array_set_x (ra0, - SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)), - SCM_MAKINUM (i0)); - else - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - scm_array_set_x (ra0, - SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)), - SCM_MAKINUM (i0)); - } - return 1; -} - - - -static int ramap_a SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -ramap_a (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NULLP - (ras) - for (; n-- > 0; i0 += inc0) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); - else - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_MAKINUM (i0)); - } - return 1; -} - -SCM_PROC(s_serial_array_map, "serial-array-map", 2, 0, 1, scm_array_map); -SCM_PROC(s_array_map, "array-map", 2, 0, 1, scm_array_map); - -SCM -scm_array_map (ra0, proc, lra) - SCM ra0; - SCM proc; - SCM lra; -{ - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_map); - switch (SCM_TYP7 (proc)) - { - default: - gencase: - scm_ramapc (ramap, proc, ra0, lra, s_array_map); - return SCM_UNSPECIFIED; - case scm_tc7_subr_1: - scm_ramapc (ramap_1, proc, ra0, lra, s_array_map); - return SCM_UNSPECIFIED; - case scm_tc7_subr_2: - case scm_tc7_subr_2o: - scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map); - return SCM_UNSPECIFIED; - case scm_tc7_cxr: - if (!SCM_SUBRF (proc)) - goto gencase; - scm_ramapc (ramap_cxr, proc, ra0, lra, s_array_map); - return SCM_UNSPECIFIED; - case scm_tc7_rpsubr: - { - ra_iproc *p; - if (SCM_FALSEP (scm_array_p (ra0, SCM_BOOL_T))) - goto gencase; - scm_array_fill_x (ra0, SCM_BOOL_T); - for (p = ra_rpsubrs; p->name; p++) - if (proc == p->sproc) - { - while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) - { - scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map); - lra = SCM_CDR (lra); - } - return SCM_UNSPECIFIED; - } - while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) - { - scm_ramapc (ramap_rp, proc, ra0, lra, s_array_map); - lra = SCM_CDR (lra); - } - return SCM_UNSPECIFIED; - } - case scm_tc7_asubr: - if SCM_NULLP - (lra) - { - SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED); - if SCM_INUMP - (fill) - { - prot = scm_array_prototype (ra0); - if (SCM_NIMP (prot) && SCM_INEXP (prot)) - fill = scm_makdbl ((double) SCM_INUM (fill), 0.0); - } - - scm_array_fill_x (ra0, fill); - } - else - { - SCM tail, ra1 = SCM_CAR (lra); - SCM v0 = (SCM_NIMP (ra0) && SCM_ARRAYP (ra0) ? SCM_ARRAY_V (ra0) : ra0); - ra_iproc *p; - /* Check to see if order might matter. - This might be an argument for a separate - SERIAL-ARRAY-MAP! */ - if (v0 == ra1 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1))) - if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0))) - goto gencase; - for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail)) - { - ra1 = SCM_CAR (tail); - if (v0 == ra1 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1))) - goto gencase; - } - for (p = ra_asubrs; p->name; p++) - if (proc == p->sproc) - { - if (ra0 != SCM_CAR (lra)) - scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), s_array_map); - lra = SCM_CDR (lra); - while (1) - { - scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map); - if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra))) - return SCM_UNSPECIFIED; - lra = SCM_CDR (lra); - } - } - scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map); - lra = SCM_CDR (lra); - if SCM_NIMP - (lra) - for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra)) - scm_ramapc (ramap_a, proc, ra0, lra, s_array_map); - } - return SCM_UNSPECIFIED; - } -} - - -static int rafe SCM_P ((SCM ra0, SCM proc, SCM ras)); - -static int -rafe (ra0, proc, ras) - SCM ra0; - SCM proc; - SCM ras; -{ - long i = SCM_ARRAY_DIMS (ra0)->lbnd; - scm_sizet i0 = SCM_ARRAY_BASE (ra0); - long inc0 = SCM_ARRAY_DIMS (ra0)->inc; - long n = SCM_ARRAY_DIMS (ra0)->ubnd; - ra0 = SCM_ARRAY_V (ra0); - if SCM_NULLP - (ras) - for (; i <= n; i++, i0 += inc0) - scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), scm_listofnull); - else - { - SCM ra1 = SCM_CAR (ras); - SCM args, *ve = &ras; - scm_sizet k, i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - ras = SCM_CDR (ras); - if SCM_NULLP - (ras) - ras = scm_nullvect; - else - { - ras = scm_vector (ras); - ve = SCM_VELTS (ras); - } - for (; i <= n; i++, i0 += inc0, i1 += inc1) - { - args = SCM_EOL; - for (k = SCM_LENGTH (ras); k--;) - args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args); - args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args); - scm_apply (proc, args, SCM_EOL); - } - } - return 1; -} - - -SCM_PROC(s_array_for_each, "array-for-each", 2, 0, 1, scm_array_for_each); - -SCM -scm_array_for_each (proc, ra0, lra) - SCM proc; - SCM ra0; - SCM lra; -{ - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG1, s_array_for_each); - scm_ramapc (rafe, proc, ra0, lra, s_array_for_each); - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_array_index_map_x, "array-index-map!", 2, 0, 0, scm_array_index_map_x); - -SCM -scm_array_index_map_x (ra, proc) - SCM ra; - SCM proc; -{ - scm_sizet i; - SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_array_index_map_x); - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_index_map_x); - switch SCM_TYP7 - (ra) - { - default: - badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_index_map_x); - case scm_tc7_vector: - { - SCM *ve = SCM_VELTS (ra); - for (i = 0; i < SCM_LENGTH (ra); i++) - ve[i] = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull); - return SCM_UNSPECIFIED; - } - case scm_tc7_string: - case scm_tc7_bvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - for (i = 0; i < SCM_LENGTH (ra); i++) - scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull), SCM_MAKINUM (i)); - return SCM_UNSPECIFIED; - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (ra), badarg); - { - SCM args = SCM_EOL; - SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_MAKINUM (-1L)); - long *vinds = SCM_VELTS (inds); - int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1; - for (k = 0; k <= kmax; k++) - vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd; - k = kmax; - do - { - if (k == kmax) - { - vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd; - i = cind (ra, inds); - for (; vinds[k] <= SCM_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++) - { - for (j = kmax + 1, args = SCM_EOL; j--;) - args = scm_cons (SCM_MAKINUM (vinds[j]), args); - scm_array_set_x (SCM_ARRAY_V (ra), scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i)); - i += SCM_ARRAY_DIMS (ra)[k].inc; - } - k--; - continue; - } - if (vinds[k] < SCM_ARRAY_DIMS (ra)[k].ubnd) - { - vinds[k]++; - k++; - continue; - } - vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd - 1; - k--; - } - while (k >= 0); - return SCM_UNSPECIFIED; - } - } -} - - -static int raeql_1 SCM_P ((SCM ra0, SCM as_equal, SCM ra1)); - -static int -raeql_1 (ra0, as_equal, ra1) - SCM ra0; - SCM as_equal; - SCM ra1; -{ - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - scm_sizet i0 = 0, i1 = 0; - long inc0 = 1, inc1 = 1; - scm_sizet n = SCM_LENGTH (ra0); - ra1 = SCM_CAR (ra1); - if SCM_ARRAYP - (ra0) - { - n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - i0 = SCM_ARRAY_BASE (ra0); - inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - } - if SCM_ARRAYP - (ra1) - { - i1 = SCM_ARRAY_BASE (ra1); - inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - } - switch SCM_TYP7 - (ra0) - { - case scm_tc7_vector: - default: - for (; n--; i0 += inc0, i1 += inc1) - { - if SCM_FALSEP - (as_equal) - { - if SCM_FALSEP - (scm_array_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))) - return 0; - } - else if SCM_FALSEP - (scm_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))) - return 0; - } - return 1; - case scm_tc7_string: - { - char *v0 = SCM_CHARS (ra0) + i0; - char *v1 = SCM_CHARS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } - case scm_tc7_bvect: - for (; n--; i0 += inc0, i1 += inc1) - if (BVE_REF (ra0, i0) != BVE_REF (ra1, i1)) - return 0; - return 1; - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *v0 = (long *) SCM_VELTS (ra0) + i0; - long *v1 = (long *) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0) + i0; - float *v1 = (float *) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0) + i0; - double *v1 = (double *) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0) + i0; - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - { - if ((*v0)[0] != (*v1)[0]) - return 0; - if ((*v0)[1] != (*v1)[1]) - return 0; - } - return 1; - } -#endif /* SCM_FLOATS */ - } -} - - - -static int raeql SCM_P ((SCM ra0, SCM as_equal, SCM ra1)); - -static int -raeql (ra0, as_equal, ra1) - SCM ra0; - SCM as_equal; - SCM ra1; -{ - SCM v0 = ra0, v1 = ra1; - scm_array_dim dim0, dim1; - scm_array_dim *s0 = &dim0, *s1 = &dim1; - scm_sizet bas0 = 0, bas1 = 0; - int k, unroll = 1, vlen = 1, ndim = 1; - if SCM_ARRAYP - (ra0) - { - ndim = SCM_ARRAY_NDIM (ra0); - s0 = SCM_ARRAY_DIMS (ra0); - bas0 = SCM_ARRAY_BASE (ra0); - v0 = SCM_ARRAY_V (ra0); - } - else - { - s0->inc = 1; - s0->lbnd = 0; - s0->ubnd = SCM_LENGTH (v0) - 1; - unroll = 0; - } - if SCM_ARRAYP - (ra1) - { - if (ndim != SCM_ARRAY_NDIM (ra1)) - return 0; - s1 = SCM_ARRAY_DIMS (ra1); - bas1 = SCM_ARRAY_BASE (ra1); - v1 = SCM_ARRAY_V (ra1); - } - else - { - if (1 != ndim) - return SCM_BOOL_F; - s1->inc = 1; - s1->lbnd = 0; - s1->ubnd = SCM_LENGTH (v1) - 1; - unroll = 0; - } - if (SCM_TYP7 (v0) != SCM_TYP7 (v1)) - return 0; - for (k = ndim; k--;) - { - if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd) - return 0; - if (unroll) - { - unroll = (s0[k].inc == s1[k].inc); - vlen *= s0[k].ubnd - s1[k].lbnd + 1; - } - } - if (unroll && bas0 == bas1 && v0 == v1) - return SCM_BOOL_T; - return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), ""); -} - - -SCM -scm_raequal (ra0, ra1) - SCM ra0; - SCM ra1; -{ - return (raeql (ra0, SCM_BOOL_T, ra1) ? SCM_BOOL_T : SCM_BOOL_F); -} - -static char s_array_equal_p[] = "array-equal?"; - - -SCM -scm_array_equal_p (ra0, ra1) - SCM ra0; - SCM ra1; -{ - if (SCM_IMP (ra0) || SCM_IMP (ra1)) - callequal:return scm_equal_p (ra0, ra1); - switch SCM_TYP7 - (ra0) - { - default: - goto callequal; - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_vector: - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra0)) - goto callequal; - } - switch SCM_TYP7 - (ra1) - { - default: - goto callequal; - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_vector: - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra1)) - goto callequal; - } - return (raeql (ra0, SCM_BOOL_F, ra1) ? SCM_BOOL_T : SCM_BOOL_F); -} - - - - -/* These tables are a kluge that will not scale well when more - * vectorized subrs are added. It is tempting to steal some bits from - * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an - * offset into a table of vectorized subrs. - */ - -static ra_iproc ra_rpsubrs[] = -{ - {"=", SCM_UNDEFINED, scm_ra_eqp}, - {"<", SCM_UNDEFINED, scm_ra_lessp}, - {"<=", SCM_UNDEFINED, scm_ra_leqp}, - {">", SCM_UNDEFINED, scm_ra_grp}, - {">=", SCM_UNDEFINED, scm_ra_greqp}, - {0, 0, 0} -}; - -static ra_iproc ra_asubrs[] = -{ - {"+", SCM_UNDEFINED, scm_ra_sum}, - {"-", SCM_UNDEFINED, scm_ra_difference}, - {"*", SCM_UNDEFINED, scm_ra_product}, - {"/", SCM_UNDEFINED, scm_ra_divide}, - {0, 0, 0} -}; - -static void -init_raprocs (subra) - ra_iproc *subra; -{ - for (; subra->name; subra++) - subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name))); -} - - -void -scm_init_ramap () -{ - init_raprocs (ra_rpsubrs); - init_raprocs (ra_asubrs); - scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p); - scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal; -#include "ramap.x" - scm_add_feature (s_array_for_each); -} - -#endif /* ARRAYS */ diff --git a/libguile/ramap.h b/libguile/ramap.h deleted file mode 100644 index da4ec2691..000000000 --- a/libguile/ramap.h +++ /dev/null @@ -1,73 +0,0 @@ -/* classes: h_files */ - -#ifndef RAMAPH -#define RAMAPH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern int scm_ra_matchp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ramapc SCM_P ((int (*cproc) (), SCM data, SCM ra0, SCM lra, char *what)); -extern int scm_array_fill_int SCM_P ((SCM ra, SCM fill, SCM ignore)); -extern SCM scm_array_fill_x SCM_P ((SCM ra, SCM fill)); -extern SCM scm_array_copy_x SCM_P ((SCM src, SCM dst)); -extern int scm_ra_eqp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_lessp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_leqp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_grp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_greqp SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_sum SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_difference SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_product SCM_P ((SCM ra0, SCM ras)); -extern int scm_ra_divide SCM_P ((SCM ra0, SCM ras)); -extern int scm_array_identity SCM_P ((SCM src, SCM dst)); -extern SCM scm_array_map SCM_P ((SCM ra0, SCM proc, SCM lra)); -extern SCM scm_array_for_each SCM_P ((SCM proc, SCM ra0, SCM lra)); -extern SCM scm_array_index_map_x SCM_P ((SCM ra, SCM proc)); -extern SCM scm_raequal SCM_P ((SCM ra0, SCM ra1)); -extern SCM scm_array_equal_p SCM_P ((SCM ra0, SCM ra1)); -extern void scm_init_ramap SCM_P ((void)); - -#endif /* RAMAPH */ diff --git a/libguile/read.c b/libguile/read.c deleted file mode 100644 index 48badf976..000000000 --- a/libguile/read.c +++ /dev/null @@ -1,768 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "extchrs.h" -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "genio.h" -#include "eval.h" -#include "unif.h" -#include "mbstrings.h" -#include "kw.h" -#include "alist.h" -#include "srcprop.h" -#include "hashtab.h" -#include "hash.h" - -#include "read.h" - - - -#define default_case_i 0 - - - -scm_option scm_read_opts[] = { - { SCM_OPTION_BOOLEAN, "copy", 0, - "Copy source code expressions." }, - { SCM_OPTION_BOOLEAN, "positions", 0, - "Record positions of source code expressions." } -}; - -SCM_PROC (s_read_options, "read-options-interface", 0, 1, 0, scm_read_options); - -SCM -scm_read_options (setting) - SCM setting; -{ - SCM ans = scm_options (setting, - scm_read_opts, - SCM_N_READ_OPTIONS, - s_read_options); - if (SCM_COPY_SOURCE_P) - SCM_RECORD_POSITIONS_P = 1; - return ans; -} - -SCM_PROC (s_read, "read", 0, 3, 0, scm_read); - -SCM -scm_read (port, case_insensitive_p, sharp) - SCM port; - SCM case_insensitive_p; - SCM sharp; -{ - int c; - SCM tok_buf, copy; - int case_i; - - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), - port, - SCM_ARG1, - s_read); - - case_i = (SCM_UNBNDP (case_insensitive_p) - ? default_case_i - : (case_insensitive_p == SCM_BOOL_F)); - - if (SCM_UNBNDP (sharp)) - sharp = SCM_BOOL_F; - - c = scm_flush_ws (port, (char *) NULL); - if (EOF == c) - return SCM_EOF_VAL; - scm_gen_ungetc (c, port); - - tok_buf = scm_makstr (30L, 0); - return scm_lreadr (&tok_buf, port, case_i, sharp, ©); -} - - - -char * -scm_grow_tok_buf (tok_buf) - SCM * tok_buf; -{ - scm_vector_set_length_x (*tok_buf, SCM_MAKINUM (2 * SCM_LENGTH (*tok_buf))); - return SCM_CHARS (*tok_buf); -} - - - -int -scm_flush_ws (port, eoferr) - SCM port; - char *eoferr; -{ - register int c; - while (1) - switch (c = scm_gen_getc (port)) - { - case EOF: - goteof: - if (eoferr) - scm_wta (SCM_UNDEFINED, "end of file in ", eoferr); - return c; - case ';': - lp: - switch (c = scm_gen_getc (port)) - { - case EOF: - goto goteof; - default: - goto lp; - case SCM_LINE_INCREMENTORS: - break; - } - break; - case SCM_LINE_INCREMENTORS: - case SCM_SINGLE_SPACES: - case '\t': - break; - default: - return c; - } -} - - - -int -scm_casei_streq (s1, s2) - char * s1; - char * s2; -{ - while (*s1 && *s2) - if (scm_downcase((int)*s1) != scm_downcase((int)*s2)) - return 0; - else - { - ++s1; - ++s2; - } - return !(*s1 || *s2); -} - - -/* recsexpr is used when recording expressions - * constructed by read:sharp. - */ - -static SCM recsexpr SCM_P ((SCM obj, int line, int column, SCM filename)); - -static SCM -recsexpr (obj, line, column, filename) - SCM obj; - int line; - int column; - SCM filename; -{ - if (SCM_IMP (obj) || SCM_NCONSP(obj)) - return obj; - { - SCM tmp = obj, copy; - /* If this sexpr is visible in the read:sharp source, we want to - keep that information, so only record non-constant cons cells - which haven't previously been read by the reader. */ - if (SCM_FALSEP (scm_whash_lookup (scm_source_whash, obj))) - { - if (SCM_COPY_SOURCE_P) - { - copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename), - SCM_UNDEFINED); - while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp)) - { - SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp), - line, - column, - filename), - SCM_UNDEFINED)); - copy = SCM_CDR (copy); - } - SCM_SETCDR (copy, tmp); - } - else - { - recsexpr (SCM_CAR (obj), line, column, filename); - while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp)) - recsexpr (SCM_CAR (tmp), line, column, filename); - copy = SCM_UNDEFINED; - } - scm_whash_insert (scm_source_whash, - obj, - scm_make_srcprops (line, - column, - filename, - copy, - SCM_EOL)); - } - return obj; - } -} - - -/* Consume an SCSH-style block comment. Assume that we've already - read the initial `#!', and eat characters until the matching `!#'. */ - -static void -skip_scsh_block_comment (port) - SCM port; -{ - char last_c = '\0'; - - for (;;) - { - int c = scm_gen_getc (port); - - if (c == EOF) - scm_wta (SCM_UNDEFINED, - "unterminated `#! ... !#' comment", "read"); - else if (c == '#' && last_c == '!') - return; - - last_c = c; - } -} - - -static char s_list[]="list"; - -SCM -scm_lreadr (tok_buf, port, case_i, sharp, copy) - SCM *tok_buf; - SCM port; - int case_i; - SCM sharp; - SCM *copy; -{ - int c; - scm_sizet j; - SCM p; - -tryagain: - c = scm_flush_ws (port, s_read); - switch (c) - { - case EOF: - return SCM_EOF_VAL; - - case '(': - return SCM_RECORD_POSITIONS_P - ? scm_lreadrecparen (tok_buf, port, s_list, case_i, sharp, copy) - : scm_lreadparen (tok_buf, port, s_list, case_i, sharp, copy); - case ')': - scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read"); - goto tryagain; - - case '\'': - p = scm_i_quote; - goto recquote; - case '`': - p = scm_i_quasiquote; - goto recquote; - case ',': - c = scm_gen_getc (port); - if ('@' == c) - p = scm_i_uq_splicing; - else - { - scm_gen_ungetc (c, port); - p = scm_i_unquote; - } - recquote: - p = scm_cons2 (p, - scm_lreadr (tok_buf, port, case_i, sharp, copy), - SCM_EOL); - if (SCM_RECORD_POSITIONS_P) - scm_whash_insert (scm_source_whash, - p, - scm_make_srcprops (SCM_LINUM (port), - SCM_COL (port) - 1, - SCM_FILENAME (port), - SCM_COPY_SOURCE_P - ? (*copy = scm_cons2 (SCM_CAR (p), - SCM_CAR (SCM_CDR (p)), - SCM_EOL)) - : SCM_UNDEFINED, - SCM_EOL)); - return p; - case '#': - c = scm_gen_getc (port); - switch (c) - { - case '(': - p = scm_lreadparen (tok_buf, port, "vector", case_i, sharp, copy); - return SCM_NULLP (p) ? scm_nullvect : scm_vector (p); - - case 't': - case 'T': - return SCM_BOOL_T; - case 'f': - case 'F': - return SCM_BOOL_F; - - case 'b': - case 'B': - case 'o': - case 'O': - case 'd': - case 'D': - case 'x': - case 'X': - case 'i': - case 'I': - case 'e': - case 'E': - scm_gen_ungetc (c, port); - c = '#'; - goto num; - - case '!': - /* start of a shell script. Parse as a block comment, - terminated by !#, just like SCSH. */ - skip_scsh_block_comment (port); - goto tryagain; - - case '*': - j = scm_read_token (c, tok_buf, port, case_i, 0); - p = scm_istr2bve (SCM_CHARS (*tok_buf) + 1, (long) (j - 1)); - if (SCM_NFALSEP (p)) - return p; - else - goto unkshrp; - - case '{': - j = scm_read_token (c, tok_buf, port, case_i, 1); - p = scm_intern (SCM_CHARS (*tok_buf), j); - if (SCM_PORT_REPRESENTATION (port) != scm_regular_port) - scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T); - return SCM_CAR (p); - - case '\\': - c = scm_gen_getc (port); - j = scm_read_token (c, tok_buf, port, case_i, 0); - if (j == 1) - return SCM_MAKICHR (c); - if (c >= '0' && c < '8') - { - p = scm_istr2int (SCM_CHARS (*tok_buf), (long) j, 8); - if (SCM_NFALSEP (p)) - return SCM_MAKICHR (SCM_INUM (p)); - } - for (c = 0; c < scm_n_charnames; c++) - if (scm_charnames[c] - && (scm_casei_streq (scm_charnames[c], SCM_CHARS (*tok_buf)))) - return SCM_MAKICHR (scm_charnums[c]); - scm_wta (SCM_UNDEFINED, "unknown # object: #\\", SCM_CHARS (*tok_buf)); - - - default: - callshrp: - if (SCM_NIMP (sharp)) - { - int line = SCM_LINUM (port); - int column = SCM_COL (port) - 2; - SCM got; - got = scm_apply (sharp, - SCM_MAKICHR (c), - scm_acons (port, SCM_EOL, SCM_EOL)); - if (SCM_UNSPECIFIED == got) - goto unkshrp; - if (SCM_RECORD_POSITIONS_P) - return *copy = recsexpr (got, line, column, - SCM_FILENAME (port)); - else - return got; - } - unkshrp:scm_wta ((SCM) SCM_MAKICHR (c), "unknown # object", ""); - } - - case '"': - j = 0; - while ('"' != (c = scm_gen_getc (port))) - { - SCM_ASSERT (EOF != c, SCM_UNDEFINED, "end of file in ", "string"); - - while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) - scm_grow_tok_buf (tok_buf); - - if (c == '\\') - switch (c = scm_gen_getc (port)) - { - case '\n': - continue; - case '0': - c = '\0'; - break; - case 'f': - c = '\f'; - break; - case 'n': - c = '\n'; - break; - case 'r': - c = '\r'; - break; - case 't': - c = '\t'; - break; - case 'a': - c = '\007'; - break; - case 'v': - c = '\v'; - break; - } - if (SCM_PORT_REPRESENTATION(port) == scm_regular_port) - { - SCM_CHARS (*tok_buf)[j] = c; - ++j; - } - else - { - int len; - len = xwctomb (SCM_CHARS (*tok_buf) + j, c); - if (len == 0) - len = 1; - SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read"); - j += len; - } - } - if (j == 0) - return scm_nullstr; - SCM_CHARS (*tok_buf)[j] = 0; - { - SCM str; - str = scm_makfromstr (SCM_CHARS (*tok_buf), j, 0); - if (SCM_PORT_REPRESENTATION(port) != scm_regular_port) - { - SCM_SETLENGTH (str, SCM_LENGTH (str), scm_tc7_mb_string); - } - return str; - } - - case'0':case '1':case '2':case '3':case '4': - case '5':case '6':case '7':case '8':case '9': - case '.': - case '-': - case '+': - num: - j = scm_read_token (c, tok_buf, port, case_i, 0); - p = scm_istring2number (SCM_CHARS (*tok_buf), (long) j, 10L); - if (SCM_NFALSEP (p)) - return p; - if (c == '#') - { - if ((j == 2) && (scm_gen_getc (port) == '(')) - { - scm_gen_ungetc ('(', port); - c = SCM_CHARS (*tok_buf)[1]; - goto callshrp; - } - scm_wta (SCM_UNDEFINED, "unknown # object", SCM_CHARS (*tok_buf)); - } - goto tok; - - case ':': - j = scm_read_token ('-', tok_buf, port, case_i, 0); - p = scm_intern (SCM_CHARS (*tok_buf), j); - if (SCM_PORT_REPRESENTATION (port) != scm_regular_port) - scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T); - return scm_make_keyword_from_dash_symbol (SCM_CAR (p)); - - default: - j = scm_read_token (c, tok_buf, port, case_i, 0); - /* fallthrough */ - - tok: - p = scm_intern (SCM_CHARS (*tok_buf), j); - if (SCM_PORT_REPRESENTATION (port) != scm_regular_port) - scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T); - return SCM_CAR (p); - } -} - -#ifdef _UNICOS -_Pragma ("noopt"); /* # pragma _CRI noopt */ -#endif - -scm_sizet -scm_read_token (ic, tok_buf, port, case_i, weird) - int ic; - SCM *tok_buf; - SCM port; - int case_i; - int weird; -{ - register scm_sizet j; - register int c; - register char *p; - - c = ic; - p = SCM_CHARS (*tok_buf); - - if (weird) - j = 0; - else - { - j = 0; - while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) - p = scm_grow_tok_buf (tok_buf); - if (SCM_PORT_REPRESENTATION(port) == scm_regular_port) - { - p[j] = c; - ++j; - } - else - { - int len; - len = xwctomb (p + j, c); - if (len == 0) - len = 1; - SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read"); - j += len; - } - } - - while (1) - { - while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf)) - p = scm_grow_tok_buf (tok_buf); - c = scm_gen_getc (port); - switch (c) - { - case '(': - case ')': - case '"': - case ';': - case SCM_WHITE_SPACES: - case SCM_LINE_INCREMENTORS: - if (weird) - goto default_case; - - scm_gen_ungetc (c, port); - case EOF: - eof_case: - p[j] = 0; - return j; - case '\\': - if (!weird) - goto default_case; - else - { - c = scm_gen_getc (port); - if (c == EOF) - goto eof_case; - else - goto default_case; - } - case '}': - if (!weird) - goto default_case; - - c = scm_gen_getc (port); - if (c == '#') - { - p[j] = 0; - return j; - } - else - { - scm_gen_ungetc (c, port); - c = '}'; - goto default_case; - } - - default: - default_case: - { - c = (case_i ? scm_downcase(c) : c); - if (SCM_PORT_REPRESENTATION(port) == scm_regular_port) - { - p[j] = c; - ++j; - } - else - { - int len; - len = xwctomb (p + j, c); - if (len == 0) - len = 1; - SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read"); - j += len; - } - } - - } - } -} - -#ifdef _UNICOS -_Pragma ("opt"); /* # pragma _CRI opt */ -#endif - -SCM -scm_lreadparen (tok_buf, port, name, case_i, sharp, copy) - SCM *tok_buf; - SCM port; - char *name; - int case_i; - SCM sharp; - SCM *copy; -{ - SCM tmp; - SCM tl; - SCM ans; - int c; - - c = scm_flush_ws (port, name); - if (')' == c) - return SCM_EOL; - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy))) - { - ans = scm_lreadr (tok_buf, port, case_i, sharp, copy); - closeit: - if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); - return ans; - } - ans = tl = scm_cons (tmp, SCM_EOL); - while (')' != (c = scm_flush_ws (port, name))) - { - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy))) - { - SCM_SETCDR (tl, scm_lreadr (tok_buf, port, case_i, sharp, copy)); - goto closeit; - } - SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL)); - tl = SCM_CDR (tl); - } - return ans; -} - - -SCM -scm_lreadrecparen (tok_buf, port, name, case_i, sharp, copy) - SCM *tok_buf; - SCM port; - char *name; - int case_i; - SCM sharp; - SCM *copy; -{ - register int c; - register SCM tmp; - register SCM tl, tl2 = SCM_EOL; - SCM ans, ans2 = SCM_EOL; - /* Need to capture line and column numbers here. */ - int line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; - - c = scm_flush_ws (port, name); - if (')' == c) - return SCM_EOL; - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy))) - { - ans = scm_lreadr (tok_buf, port, case_i, sharp, copy); - if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); - return ans; - } - /* Build the head of the list structure. */ - ans = tl = scm_cons (tmp, SCM_EOL); - if (SCM_COPY_SOURCE_P) - ans2 = tl2 = scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp) - ? *copy - : tmp, - SCM_EOL); - while (')' != (c = scm_flush_ws (port, name))) - { - scm_gen_ungetc (c, port); - if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy))) - { - SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)); - if (SCM_COPY_SOURCE_P) - SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp) - ? *copy - : tmp, - SCM_EOL)); - if (')' != (c = scm_flush_ws (port, name))) - scm_wta (SCM_UNDEFINED, "missing close paren", ""); - goto exit; - } - tl = SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL)); - if (SCM_COPY_SOURCE_P) - tl2 = SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp) - ? *copy - : tmp, - SCM_EOL)); - } -exit: - scm_whash_insert (scm_source_whash, - ans, - scm_make_srcprops (line, - column, - SCM_FILENAME (port), - SCM_COPY_SOURCE_P - ? *copy = ans2 - : SCM_UNDEFINED, - SCM_EOL)); - return ans; -} - - - - - - -void -scm_init_read () -{ - scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS); -#include "read.x" -} diff --git a/libguile/read.h b/libguile/read.h deleted file mode 100644 index 8eef1ed24..000000000 --- a/libguile/read.h +++ /dev/null @@ -1,89 +0,0 @@ -/* classes: h_files */ - -#ifndef READH -#define READH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -#include "libguile/options.h" - - -/* SCM_LINE_INCREMENTORS are the characters which cause the line count to - * be incremented for the purposes of error reporting. This feature - * is only used for scheme code loaded from files. - * - * SCM_WHITE_SPACES are other characters which should be treated like spaces - * in programs. - */ - -#define SCM_LINE_INCREMENTORS '\n' - -#ifdef MSDOS -# define SCM_SINGLE_SPACES ' ':case '\r':case '\f': case 26 -#else -# define SCM_SINGLE_SPACES ' ':case '\r':case '\f' -#endif - -#define SCM_WHITE_SPACES SCM_SINGLE_SPACES: case '\t' - -extern scm_option scm_read_opts[]; - -#define SCM_COPY_SOURCE_P scm_read_opts[0].val -#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val -#define SCM_N_READ_OPTIONS 2 - - - -extern SCM scm_read_options SCM_P ((SCM setting)); -extern SCM scm_read SCM_P ((SCM port, SCM casep, SCM sharp)); -extern char * scm_grow_tok_buf SCM_P ((SCM * tok_buf)); -extern int scm_flush_ws SCM_P ((SCM port, char *eoferr)); -extern int scm_casei_streq SCM_P ((char * s1, char * s2)); -extern SCM scm_lreadr SCM_P ((SCM * tok_buf, SCM port, int case_i, SCM sharp, SCM *copy)); -extern scm_sizet scm_read_token SCM_P ((int ic, SCM * tok_buf, SCM port, int case_i, int weird)); -extern SCM scm_lreadparen SCM_P ((SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy)); -extern SCM scm_lreadrecparen SCM_P ((SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy)); -extern void scm_init_read SCM_P ((void)); - -#endif /* READH */ diff --git a/libguile/root.c b/libguile/root.c deleted file mode 100644 index b79e7b72b..000000000 --- a/libguile/root.c +++ /dev/null @@ -1,378 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "stackchk.h" -#include "dynwind.h" -#include "eval.h" -#include "genio.h" -#include "smob.h" -#include "pairs.h" -#include "throw.h" - -#include "root.h" - - -SCM scm_sys_protects[SCM_NUM_PROTECTS]; - -long scm_tc16_root; - -#ifndef USE_THREADS -struct scm_root_state *scm_root; -#endif - - - -static SCM mark_root SCM_P ((SCM)); - -static SCM -mark_root (root) - SCM root; -{ - scm_root_state *s = SCM_ROOT_STATE (root); - SCM_SETGC8MARK (root); - scm_gc_mark (s->rootcont); - scm_gc_mark (s->dynwinds); - scm_gc_mark (s->continuation_stack); - scm_gc_mark (s->continuation_stack_ptr); - scm_gc_mark (s->progargs); - scm_gc_mark (s->exitval); - scm_gc_mark (s->cur_inp); - scm_gc_mark (s->cur_outp); - scm_gc_mark (s->cur_errp); - scm_gc_mark (s->def_inp); - scm_gc_mark (s->def_outp); - scm_gc_mark (s->def_errp); - scm_gc_mark (s->top_level_lookup_closure_var); - scm_gc_mark (s->system_transformer); - return SCM_ROOT_STATE (root) -> parent; -} - -static scm_sizet free_root SCM_P ((SCM)); - -static scm_sizet -free_root (root) - SCM root; -{ - scm_must_free ((char *) SCM_ROOT_STATE (root)); - return sizeof (scm_root_state); -} - -static int print_root SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -print_root (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<root ", port); - scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port); - scm_gen_putc('>', port); - return 1; -} - -static scm_smobfuns root_smob = -{ - mark_root, - free_root, - print_root, - 0 -}; - - - -SCM -scm_make_root (parent) - SCM parent; -{ - SCM root; - scm_root_state *root_state; - - root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state), - "scm_make_root"); - if (SCM_NIMP (parent) && SCM_ROOTP (parent)) - { - memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state)); - root_state->parent = parent; - } - else - { - root_state->parent = SCM_BOOL_F; - } - SCM_NEWCELL (root); - SCM_REDEFER_INTS; - SCM_SETCAR (root, scm_tc16_root); - SCM_SETCDR (root, root_state); - root_state->handle = root; - SCM_REALLOW_INTS; - return root; -} - -/* {call-with-dynamic-root} - * - * Suspending the current thread to evaluate a thunk on the - * same C stack but under a new root. - * - * Calls to call-with-dynamic-root return exactly once (unless - * the process is somehow exitted). - */ - -/* Some questions about cwdr: - - Couldn't the body just be a closure? Do we really need to pass - args through to it? - - The semantics are a lot like catch's; in fact, we call - scm_internal_catch to take care of that part of things. Wouldn't - it be cleaner to say that uncaught throws just disappear into the - ether (or print a message to stderr), and let the caller use catch - themselves if they want to? - - -JimB */ - -#if 0 -SCM scm_exitval; /* INUM with return value */ -#endif -static int n_dynamic_roots = 0; - - -/* cwdr fills out one of these structures, and then passes a pointer - to it through scm_internal_catch to the cwdr_body and cwdr_handler - functions, to tell them how to behave. - - A cwdr is a lot like a catch, except there is no tag (all - exceptions are caught), and the body procedure takes the arguments - passed to cwdr as A1 and ARGS. */ - -struct cwdr_body_data { - - /* Arguments to pass to the cwdr body function. */ - SCM a1, args; - - /* Scheme procedure to use as body of cwdr. */ - SCM body_proc; - - /* Scheme procedure to call if a throw occurs within the cwdr. */ - SCM handler_proc; -}; - - -/* Invoke the body of a cwdr, assuming that the throw handler has - already been set up. DATA points to a struct set up by cwdr that - says what proc to call, and what args to apply it to. */ -static SCM cwdr_body SCM_P ((void *, SCM)); - -static SCM -cwdr_body (void *data, SCM jmpbuf) -{ - struct cwdr_body_data *c = (struct cwdr_body_data *) data; - - return scm_apply (c->body_proc, c->a1, c->args); -} - - -/* Invoke the handler of a cwdr. DATA points to a struct set up by - cwdr that says what proc to call to handle the throw. */ -static SCM cwdr_handler SCM_P ((void *, SCM, SCM)); - -static SCM -cwdr_handler (void *data, SCM tag, SCM throw_args) -{ - struct cwdr_body_data *c = (struct cwdr_body_data *) data; - - return scm_apply (c->handler_proc, scm_cons (tag, throw_args), SCM_EOL); -} - - -static SCM cwdr SCM_P ((SCM thunk, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)); - -/* This is the basic code for new root creation. - * - * WARNING! The order of actions in this routine is in many ways - * critical. E. g., it is essential that an error doesn't leave Guile - * in a messed up state. */ - -static SCM -cwdr (proc, a1, args, handler, stack_start) - SCM proc; - SCM a1; - SCM args; - SCM handler; - SCM_STACKITEM *stack_start; -{ - int old_ints_disabled = scm_ints_disabled; - SCM old_rootcont, old_winds; - SCM answer; - - /* Create a fresh root continuation. - */ - { - SCM new_rootcont; - SCM_NEWCELL (new_rootcont); - SCM_REDEFER_INTS; - SCM_SETJMPBUF (new_rootcont, - scm_must_malloc ((long) sizeof (scm_contregs), - "inferior root continuation")); - SCM_SETCAR (new_rootcont, scm_tc7_contin); - SCM_DYNENV (new_rootcont) = SCM_EOL; - SCM_BASE (new_rootcont) = stack_start; - SCM_SEQ (new_rootcont) = ++n_dynamic_roots; -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (new_rootcont) = 0; -#endif - old_rootcont = scm_rootcont; - scm_rootcont = new_rootcont; - SCM_REALLOW_INTS; - } - - /* Exit caller's dynamic state. - */ - old_winds = scm_dynwinds; - scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds)); -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (old_rootcont) = scm_last_debug_frame; - scm_last_debug_frame = 0; -#endif - - /* Catch all errors. */ - { - struct cwdr_body_data c; - - c.a1 = a1; - c.args = args; - c.body_proc = proc; - c.handler_proc = handler; - - answer = scm_internal_catch (SCM_BOOL_T, cwdr_body, cwdr_handler, &c); - } - - scm_dowinds (old_winds, - scm_ilength (old_winds)); - SCM_REDEFER_INTS; -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_DFRAME (old_rootcont); -#endif - scm_rootcont = old_rootcont; - SCM_REALLOW_INTS; - scm_ints_disabled = old_ints_disabled; - return answer; -} - - -SCM_PROC(s_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root); -SCM -scm_call_with_dynamic_root (thunk, handler) - SCM thunk; - SCM handler; -{ - SCM_STACKITEM stack_place; - - return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place); -} - -SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root); -SCM -scm_dynamic_root () -{ - return scm_ulong2num (SCM_SEQ (scm_root->rootcont)); -} - -SCM -scm_apply_with_dynamic_root (proc, a1, args, handler) - SCM proc; - SCM a1; - SCM args; - SCM handler; -{ - SCM_STACKITEM stack_place; - return cwdr (proc, a1, args, handler, &stack_place); -} - - - -/* Call thunk(closure) underneath a top-level error handler. - * If an error occurs, pass the exitval through err_filter and return it. - * If no error occurs, return the value of thunk. - */ - - -#ifdef _UNICOS -typedef int setjmp_type; -#else -typedef long setjmp_type; -#endif - - - -SCM -scm_call_catching_errors (thunk, err_filter, closure) - SCM (*thunk)(); - SCM (*err_filter)(); - void *closure; -{ - SCM answer; - setjmp_type i; -#ifdef DEBUG_EXTENSIONS - SCM_DFRAME (scm_rootcont) = scm_last_debug_frame; -#endif - i = setjmp (SCM_JMPBUF (scm_rootcont)); - scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; - if (!i) - { - scm_gc_heap_lock = 0; - answer = thunk (closure); - } - else - { - scm_gc_heap_lock = 1; - answer = err_filter (scm_exitval, closure); - } - return answer; -} - -void -scm_init_root () -{ - scm_tc16_root = scm_newsmob (&root_smob); -#include "root.x" -} diff --git a/libguile/root.h b/libguile/root.h deleted file mode 100644 index 37857d47d..000000000 --- a/libguile/root.h +++ /dev/null @@ -1,157 +0,0 @@ -/* classes: h_files */ - -#ifndef ROOTH -#define ROOTH - -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - - - -#include "libguile/__scm.h" -#include "libguile/debug.h" - - - -#define scm_flo0 scm_sys_protects[0] -#define scm_listofnull scm_sys_protects[1] -#define scm_undefineds scm_sys_protects[2] -#define scm_nullvect scm_sys_protects[3] -#define scm_nullstr scm_sys_protects[4] -#define scm_symhash scm_sys_protects[5] -#define scm_weak_symhash scm_sys_protects[6] -#define scm_symhash_vars scm_sys_protects[7] -#define scm_kw_obarray scm_sys_protects[8] -#define scm_type_obj_list scm_sys_protects[9] -#define scm_first_type scm_sys_protects[10] -#define scm_stand_in_procs scm_sys_protects[11] -#define scm_object_whash scm_sys_protects[12] -#define scm_permobjs scm_sys_protects[13] -#define scm_asyncs scm_sys_protects[14] -#ifdef DEBUG_EXTENSIONS -#define scm_source_whash scm_sys_protects[15] -#define SCM_NUM_PROTECTS 16 -#else -#define SCM_NUM_PROTECTS 15 -#endif - -extern SCM scm_sys_protects[]; - - - -extern long scm_tc16_root; - -#define SCM_ROOTP(obj) (scm_tc16_root == SCM_TYP16 (obj)) -#define SCM_ROOT_STATE(root) ((scm_root_state *) SCM_CDR (root)) - -typedef struct scm_root_state -{ - SCM_STACKITEM * stack_base; - jmp_buf save_regs_gc_mark; - int errjmp_bad; - - SCM rootcont; - SCM dynwinds; - SCM continuation_stack; - SCM continuation_stack_ptr; -#ifdef DEBUG_EXTENSIONS - /* It is very inefficient to have this variable in the root state. */ - scm_debug_frame *last_debug_frame; -#endif - - SCM progargs; /* vestigial */ - SCM exitval; /* vestigial */ - - SCM cur_inp; - SCM cur_outp; - SCM cur_errp; - SCM def_inp; - SCM def_outp; - SCM def_errp; - - SCM system_transformer; - SCM top_level_lookup_closure_var; - - SCM handle; /* The root object for this root state */ - SCM parent; /* The parent root object */ -} scm_root_state; - -#define scm_stack_base (scm_root->stack_base) -#define scm_save_regs_gc_mark (scm_root->save_regs_gc_mark) -#define scm_errjmp_bad (scm_root->errjmp_bad) - -#define scm_rootcont (scm_root->rootcont) -#define scm_dynwinds (scm_root->dynwinds) -#define scm_continuation_stack (scm_root->continuation_stack) -#define scm_continuation_stack_ptr (scm_root->continuation_stack_ptr) -#define scm_progargs (scm_root->progargs) -#ifdef USE_THREADS -#define scm_last_debug_frame (scm_root->last_debug_frame) -#endif -#define scm_exitval (scm_root->exitval) -#define scm_cur_inp (scm_root->cur_inp) -#define scm_cur_outp (scm_root->cur_outp) -#define scm_cur_errp (scm_root->cur_errp) -#define scm_def_inp (scm_root->def_inp) -#define scm_def_outp (scm_root->def_outp) -#define scm_def_errp (scm_root->def_errp) -#define scm_top_level_lookup_closure_var \ - (scm_root->top_level_lookup_closure_var) -#define scm_system_transformer (scm_root->system_transformer) - -#ifdef USE_THREADS -#define scm_root ((scm_root_state *) SCM_THREAD_LOCAL_DATA) -#define scm_set_root(new_root) SCM_SET_THREAD_LOCAL_DATA (new_root) -#else /* USE_THREADS */ -extern struct scm_root_state *scm_root; -#define scm_set_root(new_root) (scm_root = (new_root)) -#endif /* USE_THREADS */ - - - -extern SCM scm_make_root SCM_P ((SCM parent)); -extern SCM scm_call_with_dynamic_root SCM_P ((SCM thunk, SCM handler)); -extern SCM scm_apply_with_dynamic_root SCM_P ((SCM proc, SCM a1, SCM args, SCM handler)); -extern SCM scm_call_catching_errors SCM_P ((SCM (*thunk)(), SCM (*err_filter)(), void * closure)); -extern void scm_init_root SCM_P ((void)); - -#endif /* ROOTH */ diff --git a/libguile/scmconfig.h.in b/libguile/scmconfig.h.in deleted file mode 100644 index 4578d3ace..000000000 --- a/libguile/scmconfig.h.in +++ /dev/null @@ -1,287 +0,0 @@ -/* scmconfig.h.in. Generated automatically from configure.in by autoheader. */ - -/* Define if on AIX 3. - System headers sometimes define this. - We just want to avoid a redefinition error message. */ -#ifndef _ALL_SOURCE -#undef _ALL_SOURCE -#endif - -/* Define to empty if the keyword does not work. */ -#undef const - -/* Define to the type of elements in the array set by `getgroups'. - Usually this is either `int' or `gid_t'. */ -#undef GETGROUPS_T - -/* Define to `int' if <sys/types.h> doesn't define. */ -#undef gid_t - -/* Define if your struct stat has st_blksize. */ -#undef HAVE_ST_BLKSIZE - -/* Define if your struct stat has st_blocks. */ -#undef HAVE_ST_BLOCKS - -/* Define if your struct stat has st_rdev. */ -#undef HAVE_ST_RDEV - -/* Define if you have <sys/wait.h> that is POSIX.1 compatible. */ -#undef HAVE_SYS_WAIT_H - -/* Define if on MINIX. */ -#undef _MINIX - -/* Define to `int' if <sys/types.h> doesn't define. */ -#undef mode_t - -/* Define if the system does not provide POSIX.1 features except - with this defined. */ -#undef _POSIX_1_SOURCE - -/* Define if you need to in order for stat and other things to work. */ -#undef _POSIX_SOURCE - -/* Define as the return type of signal handlers (int or void). */ -#undef RETSIGTYPE - -/* Define if you have the ANSI C header files. */ -#undef STDC_HEADERS - -/* Define if you can safely include both <sys/time.h> and <time.h>. */ -#undef TIME_WITH_SYS_TIME - -/* Define to `int' if <sys/types.h> doesn't define. */ -#undef uid_t - -/* Define these two if you want support for debugging of Scheme - programs. */ -#undef DEBUG_EXTENSIONS -#undef READER_EXTENSIONS - -/* Define this if your system has a way to set a stdio stream's file - descriptor. You should also copy fd.h.in to fd.h, and give the - macro SET_FILE_FD_FIELD an appropriate definition. See - configure.in for more details. */ -#undef HAVE_FD_SETTER - -/* Define this if your system has a way to set a stdio stream's file - descriptor. You should also copy fd.h.in to fd.h, and give the - macro SET_FILE_FD_FIELD an appropriate definition. See - configure.in for more details. */ -#undef HAVE_FD_SETTER - -/* Set this to the name of a field in FILE which contains the number - of buffered characters waiting to be read. */ -#undef FILE_CNT_FIELD - -/* Define this if your stdio has _gptr and _egptr fields which can - be compared to give the number of buffered characters waiting to - be read. */ -#undef FILE_CNT_GPTR - -/* Define this if your stdio has _IO_read_ptr and _IO_read_end fields - which can be compared to give the number of buffered characters - waiting to be read. */ -#undef FILE_CNT_READPTR - -/* Define this if your system defines struct linger, for use with the - getsockopt and setsockopt system calls. */ -#undef HAVE_STRUCT_LINGER - -/* Define this if floats are the same size as longs. */ -#undef SCM_SINGLES - -/* Define this if a callee's stack frame has a higher address than the - caller's stack frame. On most machines, this is not the case. */ -#undef SCM_STACK_GROWS_UP - -/* Define this if <utime.h> doesn't define struct utimbuf unless - _POSIX_SOURCE is #defined. See GUILE_STRUCT_UTIMBUF in aclocal.m4. */ -#undef UTIMBUF_NEEDS_POSIX - -/* Define this if we should #include <libc.h> when we've already - #included <unistd.h>. On some systems, they conflict, and libc.h - should be omitted. See GUILE_HEADER_LIBC_WITH_UNISTD in - aclocal.m4. */ -#undef LIBC_H_WITH_UNISTD_H - -/* Define these to indicate the current version of Guile. These - values are supposed to be supplied by the configuration system. */ -#undef GUILE_MAJOR_VERSION -#undef GUILE_MINOR_VERSION -#undef GUILE_VERSION - -/* Define if using cooperative multithreading. */ -#undef USE_COOP_THREADS - -/* Define if using "FSU" pthreads. */ -#undef USE_FSU_PTHREADS - -/* Define if using MIT pthreads. */ -#undef USE_MIT_PTHREADS - -/* Define if using PCthreads pthreads. */ -#undef USE_PCTHREADS_PTHREADS - -/* Define if using any sort of threads. */ -#undef USE_THREADS - -/* Name of this package. */ -#undef PACKAGE - -/* Define if you want support for dynamic linking. */ -#undef DYNAMIC_LINKING - -/* Define if you have the ctermid function. */ -#undef HAVE_CTERMID - -/* Define if you have the ftime function. */ -#undef HAVE_FTIME - -/* Define if you have the getcwd function. */ -#undef HAVE_GETCWD - -/* Define if you have the geteuid function. */ -#undef HAVE_GETEUID - -/* Define if you have the inet_aton function. */ -#undef HAVE_INET_ATON - -/* Define if you have the lstat function. */ -#undef HAVE_LSTAT - -/* Define if you have the mkdir function. */ -#undef HAVE_MKDIR - -/* Define if you have the mknod function. */ -#undef HAVE_MKNOD - -/* Define if you have the nice function. */ -#undef HAVE_NICE - -/* Define if you have the putenv function. */ -#undef HAVE_PUTENV - -/* Define if you have the readlink function. */ -#undef HAVE_READLINK - -/* Define if you have the rename function. */ -#undef HAVE_RENAME - -/* Define if you have the rmdir function. */ -#undef HAVE_RMDIR - -/* Define if you have the select function. */ -#undef HAVE_SELECT - -/* Define if you have the setegid function. */ -#undef HAVE_SETEGID - -/* Define if you have the seteuid function. */ -#undef HAVE_SETEUID - -/* Define if you have the setlocale function. */ -#undef HAVE_SETLOCALE - -/* Define if you have the setpgid function. */ -#undef HAVE_SETPGID - -/* Define if you have the setsid function. */ -#undef HAVE_SETSID - -/* Define if you have the shl_load function. */ -#undef HAVE_SHL_LOAD - -/* Define if you have the strerror function. */ -#undef HAVE_STRERROR - -/* Define if you have the strftime function. */ -#undef HAVE_STRFTIME - -/* Define if you have the strptime function. */ -#undef HAVE_STRPTIME - -/* Define if you have the symlink function. */ -#undef HAVE_SYMLINK - -/* Define if you have the sync function. */ -#undef HAVE_SYNC - -/* Define if you have the tcgetpgrp function. */ -#undef HAVE_TCGETPGRP - -/* Define if you have the tcsetpgrp function. */ -#undef HAVE_TCSETPGRP - -/* Define if you have the times function. */ -#undef HAVE_TIMES - -/* Define if you have the uname function. */ -#undef HAVE_UNAME - -/* Define if you have the waitpid function. */ -#undef HAVE_WAITPID - -/* Define if you have the <dirent.h> header file. */ -#undef HAVE_DIRENT_H - -/* Define if you have the <libc.h> header file. */ -#undef HAVE_LIBC_H - -/* Define if you have the <limits.h> header file. */ -#undef HAVE_LIMITS_H - -/* Define if you have the <malloc.h> header file. */ -#undef HAVE_MALLOC_H - -/* Define if you have the <memory.h> header file. */ -#undef HAVE_MEMORY_H - -/* Define if you have the <ndir.h> header file. */ -#undef HAVE_NDIR_H - -/* Define if you have the <string.h> header file. */ -#undef HAVE_STRING_H - -/* Define if you have the <sys/dir.h> header file. */ -#undef HAVE_SYS_DIR_H - -/* Define if you have the <sys/ioctl.h> header file. */ -#undef HAVE_SYS_IOCTL_H - -/* Define if you have the <sys/ndir.h> header file. */ -#undef HAVE_SYS_NDIR_H - -/* Define if you have the <sys/select.h> header file. */ -#undef HAVE_SYS_SELECT_H - -/* Define if you have the <sys/time.h> header file. */ -#undef HAVE_SYS_TIME_H - -/* Define if you have the <sys/timeb.h> header file. */ -#undef HAVE_SYS_TIMEB_H - -/* Define if you have the <sys/times.h> header file. */ -#undef HAVE_SYS_TIMES_H - -/* Define if you have the <sys/types.h> header file. */ -#undef HAVE_SYS_TYPES_H - -/* Define if you have the <sys/utime.h> header file. */ -#undef HAVE_SYS_UTIME_H - -/* Define if you have the <time.h> header file. */ -#undef HAVE_TIME_H - -/* Define if you have the <unistd.h> header file. */ -#undef HAVE_UNISTD_H - -/* Define if you have the <utime.h> header file. */ -#undef HAVE_UTIME_H - -/* Define if you have the dl library (-ldl). */ -#undef HAVE_LIBDL - -/* Define if you have the dld library (-ldld). */ -#undef HAVE_LIBDLD diff --git a/libguile/scmhob.h b/libguile/scmhob.h deleted file mode 100644 index 6bd61489a..000000000 --- a/libguile/scmhob.h +++ /dev/null @@ -1,205 +0,0 @@ -/* This was modified to try out compiling with Guile. */ - - -/* scmhob.h is a header file for scheme source compiled with hobbit4d - Copyright (C) 1992, 1993, 1994, 1995 Tanel Tammet - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 1, or (at your option) -any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -*/ - - -#include <stdio.h> -#include <ctype.h> -#include "libguile/_scm.h" - - - -#define abrt scm_abort -#define absval scm_abs -#define angle scm_angle -#define append scm_append -#define assoc scm_assoc -#define assq scm_assq -#define assv scm_assv -#define big2dbl scm_big2dbl -#define close_port scm_close_port -#define cons scm_cons -#define cur_input_port scm_current_input_port -#define cur_output_port scm_current_output_port -#define difference scm_difference -#define display scm_display -#define divide scm_divide -#define eof_objectp scm_eof_object_p -#define eqp scm_eq_p -#define equal scm_equal_p -#define eqv scm_eqv_p -#define evenp scm_even_p -#define exactp scm_exact_p -#define greaterp scm_gr_p -#define greqp scm_geq_p -#define imag_part scm_imag_part -#define in2ex scm_inexact_to_exact -#define inexactp scm_inexact_p -#define input_portp scm_input_port_p -#define intp scm_integer_p -#define length scm_length -#define leqp scm_leq_p -#define lessp scm_less_p -#define lgcd scm_gcd -#define list_ref scm_list_ref -#define list_tail scm_list_tail -#define listp scm_list_p -#define llcm scm_lcm -#define lmax scm_max -#define lmin scm_min -#define lquotient scm_quotient -#define lread(X) scm_read((X), SCM_UNDEFINED) -#define lremainder scm_remainder -#define lwrite scm_write -#define magnitude scm_magnitude -#define makcclo scm_makcclo -#define makdbl scm_makdbl -#define make_string scm_make_string -#define make_vector scm_make_vector -#define makpolar scm_make_polar -#define makrect scm_make_rectangular -#define member scm_member -#define memq scm_memq -#define memv scm_memv -#define modulo scm_modulo -#define my_time scm_get_internal_run_time -#define negativep scm_negative_p -#define newline scm_newline -#define number2string scm_number_to_string -#define oddp scm_odd_p -#define open_file scm_open_file -#define output_portp scm_output_port_p -#define peek_char scm_peek_char -#define positivep scm_positive_p -#define procedurep scm_procedure_p -#define product scm_product -#define quit scm_quit -#define read_char scm_read_char -#define real_part scm_real_part -#define realp scm_real_p -#define reverse scm_reverse -#define set_inp scm_set_current_input_port -#define set_outp scm_set_current_output_port -#define st_append scm_string_append -#define st_equal scm_string_equal_p -#define st_leqp scm_string_leq_p -#define st_lessp scm_string_less_p -#define st_set scm_string_set_x -#define stci_equal scm_string_ci_equal_p -#define stci_leqp scm_string_ci_leq_p -#define stci_lessp scm_string_ci_less_p -#define string scm_string -#define string2list scm_string_to_list -#define string2number scm_string_to_number -#define string2symbol scm_string_to_symbol -#define string_copy scm_string_copy -#define string_fill scm_string_fill_x -#define substring scm_substring -#define sum scm_sum -#define symbol2string scm_symbol_to_string -#define vector scm_vector -#define vector2list scm_vector_to_list -#define vector_ref scm_vector_ref -#define vector_set scm_vector_set_x -#define write_char scm_write_char -#define zerop scm_zero_p - - - -#define STBL_VECTOR_SET(v,k,o) (v[((long)SCM_INUM(k))] = o) -#define STBL_VECTOR_REF(v,k) (v[((long)SCM_INUM(k))]) -#define CHAR_LESSP(x,y) ((SCM_ICHR(x) < SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR_LEQP(x,y) ((SCM_ICHR(x) <= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHCI_EQ(x,y) ((upcase[SCM_ICHR(x)]==upcase[SCM_ICHR(y)]) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHCI_LESSP(x,y) ((upcase[SCM_ICHR(x)] < upcase[SCM_ICHR(y)]) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHCI_LEQP(x,y) ((upcase[SCM_ICHR(x)] <= upcase[SCM_ICHR(y)]) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR_ALPHAP(chr) ((isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F) -#define SCM_CHAR_NUMP(chr) ((isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR_WHITEP(chr) ((isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR_UPPERP(chr) ((isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR_LOWERP(chr) ((isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F) -#define CHAR2INT(chr) SCM_MAKINUM(SCM_ICHR(chr)) -#define INT2CHAR(n) SCM_MAKICHR(SCM_INUM(n)) -#define CHAR_UPCASE(chr) SCM_MAKICHR(upcase[SCM_ICHR(chr)]) -#define CHAR_DOWNCASE(chr) SCM_MAKICHR(downcase[SCM_ICHR(chr)]) -#define ST_LENGTH(str) SCM_MAKINUM(SCM_LENGTH(str)) -#define ST_REF(str,k) SCM_MAKICHR(SCM_CHARS(str)[SCM_INUM(k)]) -#define VECTOR_LENGTH(v) SCM_MAKINUM(SCM_LENGTH(v)) - -#ifdef SCM_FLOATS -#include <math.h> -#endif -#ifdef SCM_BIGDIG -#define PRE_TRANSC_FUN(x) (SCM_INUMP(x) ? (double) SCM_INUM(x) : (SCM_REALP(x) ? (double) SCM_REALPART(x) : (double) big2dbl(x))) -#else -#define PRE_TRANSC_FUN(x) (SCM_INUMP(x) ? (double) SCM_INUM(x) : (double) SCM_REALPART(x)) -#endif - -#define SIN_FUN(x) (makdbl( sin( PRE_TRANSC_FUN(x)), 0.0)) -#define COS_FUN(x) (makdbl( cos( PRE_TRANSC_FUN(x)), 0.0)) -#define TAN_FUN(x) (makdbl( tan( PRE_TRANSC_FUN(x)), 0.0)) -#define ASIN_FUN(x) (makdbl( asin( PRE_TRANSC_FUN(x)), 0.0)) -#define ACOS_FUN(x) (makdbl( acos( PRE_TRANSC_FUN(x)), 0.0)) -#define ATAN_FUN(x) (makdbl( atan( PRE_TRANSC_FUN(x)), 0.0)) -#define SINH_FUN(x) (makdbl( sinh( PRE_TRANSC_FUN(x)), 0.0)) -#define COSH_FUN(x) (makdbl( cosh( PRE_TRANSC_FUN(x)), 0.0)) -#define TANH_FUN(x) (makdbl( tanh( PRE_TRANSC_FUN(x)), 0.0)) -#define ASINH_FUN(x) (makdbl( asinh( PRE_TRANSC_FUN(x)), 0.0)) -#define ACOSH_FUN(x) (makdbl( acosh( PRE_TRANSC_FUN(x)), 0.0)) -#define ATANH_FUN(x) (makdbl( atanh( PRE_TRANSC_FUN(x)), 0.0)) -#define SQRT_FUN(x) (makdbl( sqrt( PRE_TRANSC_FUN(x)), 0.0)) -#define EXPT_FUN(x,y) (makdbl( pow(( PRE_TRANSC_FUN(x)), ( PRE_TRANSC_FUN(y))), 0.0)) -#define EXP_FUN(x) (makdbl( exp( PRE_TRANSC_FUN(x)), 0.0)) -#define LOG_FUN(x) (makdbl( log( PRE_TRANSC_FUN(x)), 0.0)) -#define ABS_FUN(x) (makdbl( fabs( PRE_TRANSC_FUN(x)), 0.0)) -#define EX2IN_FUN(x) (makdbl( PRE_TRANSC_FUN(x), 0.0)) -#define SCM_FLOOR_FUN(x) (makdbl( floor( PRE_TRANSC_FUN(x)), 0.0)) -#define CEILING_FUN(x) (makdbl( ceil( PRE_TRANSC_FUN(x)), 0.0)) -#define TRUNCATE_FUN(x) (makdbl( ltrunc( PRE_TRANSC_FUN(x)), 0.0)) -#define ROUND_FUN(x) (makdbl(round( PRE_TRANSC_FUN(x)), 0.0)) - -/* the following defs come from the #ifdef HOBBIT part of scm.h */ - -#define SBOOL(x) ((x) ? SCM_BOOL_T : SCM_BOOL_F) - -#define BOOLEAN_P(x) ((x)==SCM_BOOL_T || (x)==SCM_BOOL_F) -#define CHAR_P SCM_ICHRP -#define SYMBOL_P(x) (SCM_ISYMP(x) || (!(SCM_IMP(x)) && SCM_SYMBOLP(x))) -#define VECTOR_P(x) (!(SCM_IMP(x)) && SCM_VECTORP(x)) -#define PAIR_P(x) (!(SCM_IMP(x)) && SCM_CONSP(x)) -#define NUMBER_P SCM_INUMP -#define INTEGER_P SCM_INUMP -#define STRING_P(x) (!(SCM_IMP(x)) && SCM_STRINGP(x)) -#define NULL_P SCM_NULLP -#define ZERO_P(x) ((x)==SCM_INUM0) -#define POSITIVE_P(x) ((x) > SCM_INUM0) -#define NEGATIVE_P(x) ((x) < SCM_INUM0) - -#define NOT(x) ((x)==SCM_BOOL_F ? SCM_BOOL_T : SCM_BOOL_F) -#define SET_CAR(x,y) (CAR(x) = (SCM)(y)) -#define SET_CDR(x,y) (CDR(x) = (SCM)(y)) -#define VECTOR_SET(v,k,o) (SCM_VELTS(v)[((long)SCM_INUM(k))] = o) -#define VECTOR_REF(v,k) (SCM_VELTS(v)[((long)SCM_INUM(k))]) -#define CL_VECTOR_SET(v,k,o) (SCM_VELTS(v)[k] = o) -#define CL_VECTOR_REF(v,k) (SCM_VELTS(v)[k]) -#define GLOBAL(x) (*(x)) - -#define append2(lst1,lst2) (append(scm_cons2(lst1,lst2,SCM_EOL))) -#define procedure_pred_(x) (SCM_BOOL_T==procedurep(x)) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c deleted file mode 100644 index 7429a1598..000000000 --- a/libguile/scmsigs.c +++ /dev/null @@ -1,368 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include <signal.h> -#include "_scm.h" - -#include "scmsigs.h" - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - - - -#if (__TURBOC__==1) -#define signal ssignal /* Needed for TURBOC V1.0 */ -#endif - -#ifdef USE_MIT_PTHREADS -#undef signal -#define signal pthread_signal -#endif - - - -/* SIGRETTYPE is the type that signal handlers return. See <signal.h>*/ - -#ifdef RETSIGTYPE -#define SIGRETTYPE RETSIGTYPE -#else -#ifdef STDC_HEADERS -#if (__TURBOC__==1) -#define SIGRETTYPE int -#else -#define SIGRETTYPE void -#endif -#else -#ifdef linux -#define SIGRETTYPE void -#else -#define SIGRETTYPE int -#endif -#endif -#endif - -#ifdef vms -#ifdef __GNUC__ -#define SIGRETTYPE int -#endif -#endif - - - -#define SIGFN(NAME, SCM_NAME, SIGNAL) \ -static SIGRETTYPE \ -NAME (sig) \ - int sig; \ -{ \ - signal (SIGNAL, NAME); \ - scm_take_signal (SCM_NAME); \ -} - -#ifdef SIGHUP -SIGFN(scm_hup_signal, SCM_HUP_SIGNAL, SIGHUP) -#endif - -#ifdef SIGINT -SIGFN(scm_int_signal, SCM_INT_SIGNAL, SIGINT) -#endif - -#ifdef SIGFPE -SIGFN(scm_fpe_signal, SCM_FPE_SIGNAL, SIGFPE) -#endif - -#ifdef SIGBUS -SIGFN(scm_bus_signal, SCM_BUS_SIGNAL, SIGBUS) -#endif - -#ifdef SIGSEGV -SIGFN(scm_segv_signal, SCM_SEGV_SIGNAL, SIGSEGV) -#endif - -#ifdef SIGALRM -SIGFN(scm_alrm_signal, SCM_ALRM_SIGNAL, SIGALRM) -#endif - -#define FAKESIGFN(NAME, SCM_NAME) \ -static SIGRETTYPE \ -NAME (sig) \ - int sig; \ -{ \ - scm_take_signal (SCM_NAME); \ -} - -#if 0 -/* !!! */ -FAKESIGFN(scm_gc_signal, SCM_GC_SIGNAL) -FAKESIGFN(scm_tick_signal, SCM_TICK_SIGNAL) -#endif - - -SCM_PROC(s_alarm, "alarm", 1, 0, 0, scm_alarm); - -SCM -scm_alarm (i) - SCM i; -{ - unsigned int j; - SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_alarm); - SCM_SYSCALL (j = alarm (SCM_INUM (i))); - return SCM_MAKINUM (j); -} - - -SCM_PROC(s_pause, "pause", 0, 0, 0, scm_pause); - -SCM -scm_pause () -{ - pause (); - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_sleep, "sleep", 1, 0, 0, scm_sleep); - -SCM -scm_sleep (i) - SCM i; -{ - unsigned int j; - SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_sleep); -#ifdef __HIGHC__ - SCM_SYSCALL(j = 0; sleep(SCM_INUM(i));); -#else - SCM_SYSCALL(j = sleep(SCM_INUM(i));); -#endif - return SCM_MAKINUM (j); -} - -SCM_PROC(s_raise, "raise", 1, 0, 0, scm_raise); - -SCM -scm_raise(sig) - SCM sig; -{ - SCM_ASSERT(SCM_INUMP(sig), sig, SCM_ARG1, s_raise); -# ifdef vms - return SCM_MAKINUM(gsignal((int)SCM_INUM(sig))); -# else - return kill (getpid(), (int)SCM_INUM(sig)) ? SCM_BOOL_F : SCM_BOOL_T; -# endif -} - - -#ifdef SIGHUP -static SIGRETTYPE (*oldhup) (); -#endif - -#ifdef SIGINT -static SIGRETTYPE (*oldint) (); -#endif - -#ifdef SIGFPE -static SIGRETTYPE (*oldfpe) (); -#endif - -#ifdef SIGBUS -static SIGRETTYPE (*oldbus) (); -#endif - -#ifdef SIGSEGV /* AMIGA lacks! */ -static SIGRETTYPE (*oldsegv) (); -#endif - -#ifdef SIGALRM -static SIGRETTYPE (*oldalrm) (); -#endif - -#ifdef SIGPIPE -static SIGRETTYPE (*oldpipe) (); -#endif - - - -void -scm_init_signals () -{ -#ifdef SIGINT - oldint = signal (SIGINT, scm_int_signal); -#endif -#ifdef SIGHUP - oldhup = signal (SIGHUP, scm_hup_signal); -#endif -#ifdef SIGFPE - oldfpe = signal (SIGFPE, scm_fpe_signal); -#endif -#ifdef SIGBUS - oldbus = signal (SIGBUS, scm_bus_signal); -#endif -#ifdef SIGSEGV /* AMIGA lacks! */ - oldsegv = signal (SIGSEGV, scm_segv_signal); -#endif -#ifdef SIGALRM - alarm (0); /* kill any pending ALRM interrupts */ - oldalrm = signal (SIGALRM, scm_alrm_signal); -#endif -#ifdef SIGPIPE - oldpipe = signal (SIGPIPE, SIG_IGN); -#endif -#ifdef ultrix - siginterrupt (SIGINT, 1); - siginterrupt (SIGALRM, 1); - siginterrupt (SIGHUP, 1); - siginterrupt (SIGPIPE, 1); -#endif /* ultrix */ -} - -/* This is used in preparation for a possible fork(). Ignore all - signals before the fork so that child will catch only if it - establishes a handler */ - -void -scm_ignore_signals () -{ -#ifdef ultrix - siginterrupt (SIGINT, 0); - siginterrupt (SIGALRM, 0); - siginterrupt (SIGHUP, 0); - siginterrupt (SIGPIPE, 0); -#endif /* ultrix */ - signal (SIGINT, SIG_IGN); -#ifdef SIGHUP - signal (SIGHUP, SIG_DFL); -#endif -#ifdef SCM_FLOATS - signal (SIGFPE, SIG_DFL); -#endif -#ifdef SIGBUS - signal (SIGBUS, SIG_DFL); -#endif -#ifdef SIGSEGV /* AMIGA lacks! */ - signal (SIGSEGV, SIG_DFL); -#endif - /* Some documentation claims that ALRMs are cleared accross forks. - If this is not always true then the value returned by alarm(0) - will have to be saved and scm_unignore_signals() will have to - reinstate it. */ - /* This code should be neccessary only if the forked process calls - alarm() without establishing a handler: - #ifdef SIGALRM - oldalrm = signal(SIGALRM, SIG_DFL); - #endif */ - /* These flushes are per warning in man page on fork(). */ - fflush (stdout); - fflush (stderr); -} - - -void -scm_unignore_signals () -{ - signal (SIGINT, scm_int_signal); -#ifdef SIGHUP - signal (SIGHUP, scm_hup_signal); -#endif -#ifdef SCM_FLOATS - signal (SIGFPE, scm_fpe_signal); -#endif -#ifdef SIGBUS - signal (SIGBUS, scm_bus_signal); -#endif -#ifdef SIGSEGV /* AMIGA lacks! */ - signal (SIGSEGV, scm_segv_signal); -#endif -#ifdef SIGALRM - signal (SIGALRM, scm_alrm_signal); -#endif -#ifdef ultrix - siginterrupt (SIGINT, 1); - siginterrupt (SIGALRM, 1); - siginterrupt (SIGHUP, 1); - siginterrupt (SIGPIPE, 1); -#endif /* ultrix */ -} - -SCM_PROC (s_restore_signals, "restore-signals", 0, 0, 0, scm_restore_signals); - -SCM -scm_restore_signals () -{ -#ifdef ultrix - siginterrupt (SIGINT, 0); - siginterrupt (SIGALRM, 0); - siginterrupt (SIGHUP, 0); - siginterrupt (SIGPIPE, 0); -#endif /* ultrix */ - signal (SIGINT, oldint); -#ifdef SIGHUP - signal (SIGHUP, oldhup); -#endif -#ifdef SCM_FLOATS - signal (SIGFPE, oldfpe); -#endif -#ifdef SIGBUS - signal (SIGBUS, oldbus); -#endif -#ifdef SIGSEGV /* AMIGA lacks! */ - signal (SIGSEGV, oldsegv); -#endif -#ifdef SIGPIPE - signal (SIGPIPE, oldpipe); -#endif -#ifdef SIGALRM - alarm (0); /* kill any pending ALRM interrupts */ - signal (SIGALRM, oldalrm); -#endif - return SCM_UNSPECIFIED; -} - - - -void -scm_init_scmsigs () -{ -#include "scmsigs.x" -} - diff --git a/libguile/scmsigs.h b/libguile/scmsigs.h deleted file mode 100644 index 3b8bdc48c..000000000 --- a/libguile/scmsigs.h +++ /dev/null @@ -1,60 +0,0 @@ -/* classes: h_files */ - -#ifndef SCMSIGSH -#define SCMSIGSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -extern SCM scm_alarm SCM_P ((SCM i)); -extern SCM scm_pause SCM_P ((void)); -extern SCM scm_sleep SCM_P ((SCM i)); -extern SCM scm_raise SCM_P ((SCM sig)); -extern void scm_init_signals SCM_P ((void)); -extern void scm_ignore_signals SCM_P ((void)); -extern void scm_unignore_signals SCM_P ((void)); -extern SCM scm_restore_signals SCM_P ((void)); -extern void scm_init_scmsigs SCM_P ((void)); - -#endif /* SCMSIGSH */ diff --git a/libguile/sequences.c b/libguile/sequences.c deleted file mode 100644 index 38c59e082..000000000 --- a/libguile/sequences.c +++ /dev/null @@ -1,113 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "sequences.h" - - - - - -int -scm_obj_length (obj) - SCM obj; -{ - int i; - i = scm_ilength(obj); - if (i >= 0) - return i; - else if (SCM_NIMP (obj)) - { - if (SCM_ROSTRINGP (obj)) - return SCM_ROLENGTH (obj); - else if (SCM_VECTORP (obj)) - return SCM_LENGTH (obj); - else - return -1; - } - else - return -1; -} - - -SCM_PROC(s_length, "length", 1, 0, 0, scm_length); - -SCM -scm_length(x) - SCM x; -{ - int i; - i = scm_obj_length(x); - if (i >= 0) - return SCM_MAKINUM (i); - else - { - SCM_ASSERT(0, x, SCM_ARG1, s_length); - return SCM_BOOL_F; - } -} - - - - - -SCM_PROC (s_reverse, "reverse", 1, 0, 0, scm_reverse); - -SCM -scm_reverse (objs) - SCM objs; -{ - return scm_list_reverse (objs); -} - - - - - -void -scm_init_sequences () -{ -#include "sequences.x" -} - diff --git a/libguile/sequences.h b/libguile/sequences.h deleted file mode 100644 index 6520457fc..000000000 --- a/libguile/sequences.h +++ /dev/null @@ -1,59 +0,0 @@ -/* classes: h_files */ - -#ifndef SEQUENCESH -#define SEQUENCESH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - - - - - -extern int scm_obj_length SCM_P ((SCM obj)); -extern SCM scm_length SCM_P ((SCM x)); -extern SCM scm_reverse SCM_P ((SCM objs)); -extern void scm_init_sequences SCM_P ((void)); - -#endif /* SEQUENCESH */ diff --git a/libguile/simpos.c b/libguile/simpos.c deleted file mode 100644 index ee0f7a94d..000000000 --- a/libguile/simpos.c +++ /dev/null @@ -1,152 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "scmsigs.h" -#include "simpos.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - -extern int system(); - - -#ifndef _Windows -SCM_PROC(s_system, "system", 1, 0, 0, scm_system); - -SCM -scm_system(cmd) - SCM cmd; -{ - SCM_ASSERT(SCM_NIMP(cmd) && SCM_ROSTRINGP(cmd), cmd, SCM_ARG1, s_system); - if (SCM_ROSTRINGP (cmd)) - cmd = scm_makfromstr (SCM_ROCHARS (cmd), SCM_ROLENGTH (cmd), 0); - scm_ignore_signals(); -# ifdef AZTEC_C - cmd = SCM_MAKINUM(Execute(SCM_ROCHARS(cmd), 0, 0)); -# else - cmd = SCM_MAKINUM(0L+system(SCM_ROCHARS(cmd))); -# endif - scm_unignore_signals(); - return cmd; -} -#endif - -extern char *getenv(); -SCM_PROC (s_getenv, "getenv", 1, 0, 0, scm_getenv); - -SCM -scm_getenv(nam) - SCM nam; -{ - char *val; - SCM_ASSERT(SCM_NIMP(nam) && SCM_ROSTRINGP(nam), nam, SCM_ARG1, s_getenv); - if (SCM_ROSTRINGP (nam)) - nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0); - val = getenv(SCM_CHARS(nam)); - return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F; -} - -#ifdef vms -# define SYSTNAME "VMS" -#endif -#ifdef unix -# define SYSTNAME "UNIX" -#endif -#ifdef MWC -# define SYSTNAME "COHERENT" -#endif -#ifdef _Windows -# define SYSTNAME "WINDOWS" -#else -# ifdef MSDOS -# define SYSTNAME "MS-DOS" -# endif -#endif -#ifdef __EMX__ -# define SYSTNAME "OS/2" -#endif -#ifdef __IBMC__ -# define SYSTNAME "OS/2" -#endif -#ifdef THINK_C -# define SYSTNAME "THINKC" -#endif -#ifdef AMIGA -# define SYSTNAME "AMIGA" -#endif -#ifdef atarist -# define SYSTNAME "ATARIST" -#endif -#ifdef mach -# define SYSTNAME "MACH" -#endif -#ifdef ARM_ULIB -# define SYSTNAME "ACORN" -#endif - -SCM_PROC(s_software_type, "software-type", 0, 0, 0, scm_software_type); - -SCM -scm_software_type() -{ -#ifdef nosve - return SCM_CAR(scm_intern("nosve", 5)); -#else - return SCM_CAR(scm_intern(SYSTNAME, sizeof SYSTNAME/sizeof(char) -1)); -#endif -} - - -void -scm_init_simpos () -{ -#include "simpos.x" -} - diff --git a/libguile/simpos.h b/libguile/simpos.h deleted file mode 100644 index 023966ad1..000000000 --- a/libguile/simpos.h +++ /dev/null @@ -1,55 +0,0 @@ -/* classes: h_files */ - -#ifndef SIMPOSH -#define SIMPOSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - -extern SCM scm_system SCM_P ((SCM cmd)); -extern SCM scm_getenv SCM_P ((SCM nam)); -extern SCM scm_software_type SCM_P ((void)); -extern void scm_init_simpos SCM_P ((void)); - -#endif /* SIMPOSH */ diff --git a/libguile/smob.c b/libguile/smob.c deleted file mode 100644 index 90c27f6fe..000000000 --- a/libguile/smob.c +++ /dev/null @@ -1,129 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "smob.h" - -#ifdef HAVE_MALLOC_H -#include <malloc.h> -#endif - - - -/* scm_smobs scm_numsmob - * implement a dynamicly resized array of smob records. - * Indexes into this table are used when generating type - * tags for smobjects (if you know a tag you can get an index and conversely). - */ -scm_sizet scm_numsmob; -scm_smobfuns *scm_smobs; - - -long -scm_newsmob (smob) - scm_smobfuns *smob; -{ - char *tmp; - if (255 <= scm_numsmob) - goto smoberr; - SCM_DEFER_INTS; - SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_smobs, (1 + scm_numsmob) * sizeof (scm_smobfuns))); - if (tmp) - { - scm_smobs = (scm_smobfuns *) tmp; - scm_smobs[scm_numsmob].mark = smob->mark; - scm_smobs[scm_numsmob].free = smob->free; - scm_smobs[scm_numsmob].print = smob->print; - scm_smobs[scm_numsmob].equalp = smob->equalp; - scm_numsmob++; - } - SCM_ALLOW_INTS; - if (!tmp) - smoberr:scm_wta (SCM_MAKINUM ((long) scm_numsmob), (char *) SCM_NALLOC, "newsmob"); - return scm_tc7_smob + (scm_numsmob - 1) * 256; -} - -/* {Initialization for i/o types, float, bignum, the type of free cells} - */ - -static scm_smobfuns freecell = -{ - scm_mark0, - scm_free0, - 0, - 0 -}; - -static scm_smobfuns flob = -{ - scm_mark0, - /*flofree*/ 0, - scm_floprint, - scm_floequal -}; - -static scm_smobfuns bigob = -{ - scm_mark0, - /*bigfree*/ 0, - scm_bigprint, - scm_bigequal -}; - - - - -void -scm_smob_prehistory () -{ - scm_numsmob = 0; - scm_smobs = (scm_smobfuns *) malloc (7 * sizeof (scm_smobfuns)); - - /* WARNING: These scm_newsmob calls must be done in this order */ - scm_newsmob (&freecell); - scm_newsmob (&flob); - scm_newsmob (&bigob); - scm_newsmob (&bigob); /* n.b.: two smobs, one smobfuns */ -} - diff --git a/libguile/smob.h b/libguile/smob.h deleted file mode 100644 index cf5712fc7..000000000 --- a/libguile/smob.h +++ /dev/null @@ -1,78 +0,0 @@ -/* classes: h_files */ - -#ifndef SMOBH -#define SMOBH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - -typedef struct scm_smobfuns -{ - SCM (*mark) SCM_P ((SCM)); - scm_sizet (*free) SCM_P ((SCM)); - int (*print) SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - SCM (*equalp) SCM_P ((SCM, SCM)); -} scm_smobfuns; - - - -#define SCM_SMOBNUM(x) (0x0ff & (SCM_CAR(x)>>8)); -#define SCM_PTOBNUM(x) (0x0ff & (SCM_CAR(x)>>8)); - -extern scm_sizet scm_numsmob; -extern scm_smobfuns *scm_smobs; - - - -/* Everyone who uses smobs needs to print. */ -#include "libguile/ports.h" -#include "libguile/genio.h" - -/* ... and they all need to GC. */ -#include "libguile/markers.h" - - -extern long scm_newsmob SCM_P ((scm_smobfuns *smob)); -extern void scm_smob_prehistory SCM_P ((void)); - -#endif /* SMOBH */ diff --git a/libguile/snarf.h b/libguile/snarf.h deleted file mode 100644 index 2104531aa..000000000 --- a/libguile/snarf.h +++ /dev/null @@ -1,94 +0,0 @@ -/* classes: h_files */ - -/* Macros for snarfing initialization actions from C source. */ - -#ifndef LIBGUILE_SNARF_H -#define LIBGUILE_SNARF_H - -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - - -#ifndef SCM_MAGIC_SNARFER -#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ - static char RANAME[]=STR -#define SCM_PROC1(RANAME, STR, TYPE, CFN) \ - static char RANAME[]=STR -#else -#ifdef __cplusplus -#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ -%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*) (...)) CFN) -#define SCM_PROC1(RANAME, STR, TYPE, CFN) \ -%%% scm_make_subr(RANAME, TYPE, (SCM (*)(...)) CFN) -#else /* not __cplusplus */ -#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \ -%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, CFN) -#define SCM_PROC1(RANAME, STR, TYPE, CFN) \ -%%% scm_make_subr(RANAME, TYPE, CFN) -#endif /* not __cplusplus */ -#endif - -#ifndef SCM_MAGIC_SNARFER -#define SCM_SYMBOL(c_name, scheme_name) \ - static SCM c_name = SCM_BOOL_F -#else -#define SCM_SYMBOL(C_NAME, SCHEME_NAME) \ -%%% C_NAME = scm_permanent_object (SCM_CAR (scm_intern0 (SCHEME_NAME))) -#endif - - -#ifndef SCM_MAGIC_SNARFER -#define SCM_GLOBAL(c_name, scheme_name) \ - static SCM c_name = SCM_BOOL_F -#else -#define SCM_GLOBAL(C_NAME, SCHEME_NAME) \ -%%% C_NAME = scm_permanent_object (scm_intern0 (SCHEME_NAME)); SCM_SETCDR (C_NAME, SCM_BOOL_F) -#endif - - -#ifndef SCM_MAGIC_SNARFER -#define SCM_CONST_LONG(C_NAME, SCHEME_NAME,VALUE) \ - static SCM C_NAME = SCM_BOOL_F -#else -#define SCM_CONST_LONG(C_NAME, SCHEME_NAME,VALUE) \ -%%% C_NAME = scm_permanent_object (scm_intern0 (SCHEME_NAME)); SCM_SETCDR (C_NAME, scm_long2num (VALUE)) -#endif - -#endif /* LIBGUILE_SNARF_H */ diff --git a/libguile/socket.c b/libguile/socket.c deleted file mode 100644 index d28cd104e..000000000 --- a/libguile/socket.c +++ /dev/null @@ -1,398 +0,0 @@ -/* "socket.c" internet socket support for client/server in SCM - * Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -/* Written in 1994 by Aubrey Jaffer. - * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion. - * Rewritten by Gary Houston to be a closer interface to the C socket library. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "feature.h" - -#include "socket.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - -#include <sys/types.h> -#include <sys/socket.h> -#include <sys/un.h> -#include <netinet/in.h> -#include <netdb.h> -#include <arpa/inet.h> - - - -#ifndef STDC_HEADERS -int close (); -#endif /* STDC_HEADERS */ - -extern int inet_aton (); - -SCM_PROC (s_sys_inet_aton, "inet-aton", 1, 0, 0, scm_sys_inet_aton); - -SCM -scm_sys_inet_aton (address) - SCM address; -{ - struct in_addr soka; - - SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_sys_inet_aton); - if (SCM_SUBSTRP (address)) - address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0); - if (inet_aton (SCM_ROCHARS (address), &soka) == 0) - scm_syserror (s_sys_inet_aton); - return scm_ulong2num (ntohl (soka.s_addr)); -} - - -SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa); - -SCM -scm_inet_ntoa (inetid) - SCM inetid; -{ - struct in_addr addr; - char *s; - SCM answer; - addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa)); - SCM_DEFER_INTS; - s = inet_ntoa (addr); - answer = scm_makfromstr (s, strlen (s), 0); - SCM_ALLOW_INTS; - return answer; -} - -SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof); - -SCM -scm_inet_netof (address) - SCM address; -{ - struct in_addr addr; - addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof)); - return scm_ulong2num ((unsigned long) inet_netof (addr)); -} - -SCM_PROC (s_lnaof, "lnaof", 1, 0, 0, scm_lnaof); - -SCM -scm_lnaof (address) - SCM address; -{ - struct in_addr addr; - addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof)); - return scm_ulong2num ((unsigned long) inet_lnaof (addr)); -} - - -SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr); - -SCM -scm_inet_makeaddr (net, lna) - SCM net; - SCM lna; -{ - struct in_addr addr; - unsigned long netnum; - unsigned long lnanum; - - netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr); - lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr); - addr = inet_makeaddr (netnum, lnanum); - return scm_ulong2num (ntohl (addr.s_addr)); -} - - -/* !!! Doesn't take address format. - * Assumes hostent stream isn't reused. - */ - -SCM_PROC (s_sys_gethost, "gethost", 0, 1, 0, scm_sys_gethost); - -SCM -scm_sys_gethost (name) - SCM name; -{ - SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED, SCM_BOOL_F); - SCM *ve = SCM_VELTS (ans); - SCM lst = SCM_EOL; - struct hostent *entry; - struct in_addr inad; - char **argv; - int i = 0; -#ifdef HAVE_GETHOSTENT - if (SCM_UNBNDP (name)) - { - SCM_DEFER_INTS; - entry = gethostent (); - } - else -#endif - if (SCM_NIMP (name) && SCM_STRINGP (name)) - { - SCM_DEFER_INTS; - entry = gethostbyname (SCM_CHARS (name)); - } - else - { - inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_sys_gethost)); - SCM_DEFER_INTS; - entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET); - } - SCM_ALLOW_INTS; - if (!entry) - scm_syserror (s_sys_gethost); - ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0); - ve[1] = scm_makfromstrs (-1, entry->h_aliases); - ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L); - ve[3] = SCM_MAKINUM (entry->h_length + 0L); - if (sizeof (struct in_addr) != entry->h_length) - { - ve[4] = SCM_BOOL_F; - return ans; - } - for (argv = entry->h_addr_list; argv[i]; i++); - while (i--) - { - inad = *(struct in_addr *) argv[i]; - lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst); - } - ve[4] = lst; - return ans; -} - - -SCM_PROC (s_sys_getnet, "getnet", 0, 1, 0, scm_sys_getnet); - -SCM -scm_sys_getnet (name) - SCM name; -{ - SCM ans; - SCM *ve; - struct netent *entry; - - ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (ans); - if (SCM_UNBNDP (name)) - { - SCM_DEFER_INTS; - entry = getnetent (); - } - else if (SCM_NIMP (name) && SCM_STRINGP (name)) - { - SCM_DEFER_INTS; - entry = getnetbyname (SCM_CHARS (name)); - } - else - { - unsigned long netnum; - netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getnet); - SCM_DEFER_INTS; - entry = getnetbyaddr (netnum, AF_INET); - } - SCM_ALLOW_INTS; - if (!entry) - scm_syserror (s_sys_getnet); - ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0); - ve[1] = scm_makfromstrs (-1, entry->n_aliases); - ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L); - ve[3] = scm_ulong2num (entry->n_net + 0L); - return ans; -} - -SCM_PROC (s_sys_getproto, "getproto", 0, 1, 0, scm_sys_getproto); - -SCM -scm_sys_getproto (name) - SCM name; -{ - SCM ans; - SCM *ve; - struct protoent *entry; - - ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (ans); - if (SCM_UNBNDP (name)) - { - SCM_DEFER_INTS; - entry = getprotoent (); - } - else if (SCM_NIMP (name) && SCM_STRINGP (name)) - { - SCM_DEFER_INTS; - entry = getprotobyname (SCM_CHARS (name)); - } - else - { - unsigned long protonum; - protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getproto); - SCM_DEFER_INTS; - entry = getprotobynumber (protonum); - } - SCM_ALLOW_INTS; - if (!entry) - scm_syserror (s_sys_getproto); - ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0); - ve[1] = scm_makfromstrs (-1, entry->p_aliases); - ve[2] = SCM_MAKINUM (entry->p_proto + 0L); - return ans; -} - - -static SCM scm_return_entry SCM_P ((struct servent *entry)); - -static SCM -scm_return_entry (entry) - struct servent *entry; -{ - SCM ans; - SCM *ve; - - ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F); - ve = SCM_VELTS (ans); - ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0); - ve[1] = scm_makfromstrs (-1, entry->s_aliases); - ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L); - ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0); - SCM_ALLOW_INTS; - return ans; -} - -SCM_PROC (s_sys_getserv, "getserv", 0, 2, 0, scm_sys_getserv); - -SCM -scm_sys_getserv (name, proto) - SCM name; - SCM proto; -{ - struct servent *entry; - if (SCM_UNBNDP (name)) - { - SCM_DEFER_INTS; - entry = getservent (); - if (!entry) - scm_syserror (s_sys_getserv); - return scm_return_entry (entry); - } - SCM_ASSERT (SCM_NIMP (proto) && SCM_STRINGP (proto), proto, SCM_ARG2, s_sys_getserv); - if (SCM_NIMP (name) && SCM_STRINGP (name)) - { - SCM_DEFER_INTS; - entry = getservbyname (SCM_CHARS (name), SCM_CHARS (proto)); - } - else - { - SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_sys_getserv); - SCM_DEFER_INTS; - entry = getservbyport (SCM_INUM (name), SCM_CHARS (proto)); - } - if (!entry) - scm_syserror (s_sys_getserv); - return scm_return_entry (entry); -} - -SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost); - -SCM -scm_sethost (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endhostent (); - else - sethostent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet); - -SCM -scm_setnet (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endnetent (); - else - setnetent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto); - -SCM -scm_setproto (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endprotoent (); - else - setprotoent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv); - -SCM -scm_setserv (arg) - SCM arg; -{ - if (SCM_UNBNDP (arg)) - endservent (); - else - setservent (SCM_NFALSEP (arg)); - return SCM_UNSPECIFIED; -} - - -void -scm_init_socket () -{ - scm_add_feature ("socket"); -#include "socket.x" -} - - diff --git a/libguile/socket.h b/libguile/socket.h deleted file mode 100644 index b87afb18f..000000000 --- a/libguile/socket.h +++ /dev/null @@ -1,69 +0,0 @@ -/* classes: h_files */ - -#ifndef SOCKETH -#define SOCKETH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - -extern SCM scm_sys_gethost SCM_P ((SCM name)); -extern SCM scm_sys_inet_aton SCM_P ((SCM address)); -extern SCM scm_inet_ntoa SCM_P ((SCM inetid)); -extern SCM scm_inet_netof SCM_P ((SCM address)); -extern SCM scm_lnaof SCM_P ((SCM address)); -extern SCM scm_inet_makeaddr SCM_P ((SCM net, SCM lna)); -extern SCM scm_sys_getnet SCM_P ((SCM name)); -extern SCM scm_sys_getproto SCM_P ((SCM name)); -extern SCM scm_sys_getserv SCM_P ((SCM name, SCM proto)); -extern SCM scm_sethost SCM_P ((SCM arg)); -extern SCM scm_setnet SCM_P ((SCM arg)); -extern SCM scm_setproto SCM_P ((SCM arg)); -extern SCM scm_setserv SCM_P ((SCM arg)); -extern void scm_init_socket SCM_P ((void)); - -#endif /* SOCKETH */ diff --git a/libguile/srcprop.c b/libguile/srcprop.c deleted file mode 100644 index 86705826f..000000000 --- a/libguile/srcprop.c +++ /dev/null @@ -1,363 +0,0 @@ -/* Copyright (C) 1995,1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include <stdio.h> -#include "_scm.h" -#include "smob.h" -#include "alist.h" -#include "debug.h" -#include "hashtab.h" -#include "hash.h" -#include "weaks.h" - -#include "srcprop.h" - -/* {Source Properties} - * - * Properties of source list expressions. - * Five of these have special meaning and optimized storage: - * - * filename string The name of the source file. - * copy list A copy of the list expression. - * line integer The source code line number. - * column integer The source code column number. - * breakpoint boolean Sets a breakpoint on this form. - * - * Most properties above can be set by the reader. - * - */ - -SCM scm_i_filename; -SCM scm_i_copy; -SCM scm_i_line; -SCM scm_i_column; -SCM scm_i_breakpoint; - -long scm_tc16_srcprops; -static scm_srcprops_chunk *srcprops_chunklist = 0; -static scm_srcprops *srcprops_freelist = 0; - - -static SCM marksrcprops SCM_P ((SCM obj)); - -static SCM -marksrcprops (obj) - SCM obj; -{ - SCM_SETGC8MARK (obj); - scm_gc_mark (SRCPROPFNAME (obj)); - scm_gc_mark (SRCPROPCOPY (obj)); - return SRCPROPPLIST (obj); -} - - -static scm_sizet freesrcprops SCM_P ((SCM obj)); - -static scm_sizet -freesrcprops (obj) - SCM obj; -{ - *((scm_srcprops **) SCM_CDR (obj)) = srcprops_freelist; - srcprops_freelist = (scm_srcprops *) SCM_CDR (obj); - return 0; /* srcprops_chunks are not freed until leaving guile */ -} - - -static int prinsrcprops SCM_P ((SCM obj, SCM port, scm_print_state *pstate)); - -static int -prinsrcprops (obj, port, pstate) - SCM obj; - SCM port; - scm_print_state *pstate; -{ - int writingp = SCM_WRITINGP (pstate); - scm_gen_puts (scm_regular_string, "#<srcprops ", port); - SCM_SET_WRITINGP (pstate, 1); - scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate); - SCM_SET_WRITINGP (pstate, writingp); - scm_gen_putc ('>', port); - return 1; -} - -static scm_smobfuns srcpropssmob = -{marksrcprops, freesrcprops, prinsrcprops, 0}; - - -SCM -scm_make_srcprops (line, col, filename, copy, plist) - int line; - int col; - SCM filename; - SCM copy; - SCM plist; -{ - register SCM ans; - register scm_srcprops *ptr; - SCM_DEFER_INTS; - if ((ptr = srcprops_freelist) != NULL) - srcprops_freelist = *(scm_srcprops **)ptr; - else - { - int i; - scm_srcprops_chunk *mem; - scm_sizet n = sizeof (scm_srcprops_chunk) - + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1); - SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n)); - SCM_ASSERT (mem, SCM_UNDEFINED, SCM_NALLOC, "srcprops"); - scm_mallocated += n; - mem->next = srcprops_chunklist; - srcprops_chunklist = mem; - ptr = &mem->srcprops[0]; - for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i) - *(scm_srcprops **)&ptr[i] = &ptr[i + 1]; - *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0; - srcprops_freelist = (scm_srcprops *) &ptr[1]; - } - SCM_NEWCELL (ans); - SCM_SETCAR (ans, scm_tc16_srcprops); - ptr->pos = SRCPROPMAKPOS (line, col); - ptr->fname = filename; - ptr->copy = copy; - ptr->plist = plist; - SCM_SETCDR (ans, (SCM) ptr); - SCM_ALLOW_INTS; - return ans; -} - - -SCM -scm_srcprops_to_plist (obj) - SCM obj; -{ - SCM plist = SRCPROPPLIST (obj); - if (!SCM_UNBNDP (SRCPROPCOPY (obj))) - plist = scm_acons (scm_i_copy, SRCPROPCOPY (obj), plist); - if (!SCM_UNBNDP (SRCPROPFNAME (obj))) - plist = scm_acons (scm_i_filename, SRCPROPFNAME (obj), plist); - plist = scm_acons (scm_i_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist); - plist = scm_acons (scm_i_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist); - plist = scm_acons (scm_i_breakpoint, SRCPROPBRK (obj), plist); - return plist; -} - -SCM_PROC (s_source_properties, "source-properties", 1, 0, 0, scm_source_properties); - -SCM -scm_source_properties (obj) - SCM obj; -{ - SCM p; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_properties); - if (SCM_MEMOIZEDP (obj)) - obj = SCM_MEMOIZED_EXP (obj); -#ifndef SCM_RECKLESS - else if (SCM_NCONSP (obj)) - scm_wrong_type_arg (s_source_properties, 1, obj); -#endif - p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL); - if (p != (SCM) NULL && SRCPROPSP (p)) - return scm_srcprops_to_plist (p); - return SCM_EOL; -} - -/* Perhaps this procedure should look through an alist - and try to make a srcprops-object...? */ -SCM_PROC (s_set_source_properties_x, "set-source-properties!", 2, 0, 0, scm_set_source_properties_x); - -SCM -scm_set_source_properties_x (obj, plist) - SCM obj; - SCM plist; -{ - SCM handle; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_properties_x); - if (SCM_MEMOIZEDP (obj)) - obj = SCM_MEMOIZED_EXP (obj); -#ifndef SCM_RECKLESS - else if (SCM_NCONSP (obj)) - scm_wrong_type_arg (s_set_source_properties_x, 1, obj); -#endif - handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist); - SCM_SETCDR (handle, plist); - return plist; -} - -SCM_PROC (s_source_property, "source-property", 2, 0, 0, scm_source_property); - -SCM -scm_source_property (obj, key) - SCM obj; - SCM key; -{ - SCM p; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_property); - if (SCM_MEMOIZEDP (obj)) - obj = SCM_MEMOIZED_EXP (obj); -#ifndef SCM_RECKLESS - else if (SCM_NCONSP (obj)) - scm_wrong_type_arg (s_source_property, 1, obj); -#endif - p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); - if (SCM_IMP (p) || !SRCPROPSP (p)) - goto plist; - if (scm_i_breakpoint == key) p = SRCPROPBRK (p); - else if (scm_i_line == key) p = SCM_MAKINUM (SRCPROPLINE (p)); - else if (scm_i_column == key) p = SCM_MAKINUM (SRCPROPCOL (p)); - else if (scm_i_filename == key) p = SRCPROPFNAME (p); - else if (scm_i_copy == key) p = SRCPROPCOPY (p); - else - { - p = SRCPROPPLIST (p); - plist: - p = scm_assoc (key, p); - return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F); - } - return SCM_UNBNDP (p) ? SCM_BOOL_F : p; -} - -SCM_PROC (s_set_source_property_x, "set-source-property!", 3, 0, 0, scm_set_source_property_x); - -SCM -scm_set_source_property_x (obj, key, datum) - SCM obj; - SCM key; - SCM datum; -{ - scm_whash_handle h; - SCM p; - SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_property_x); - if (SCM_MEMOIZEDP (obj)) - obj = SCM_MEMOIZED_EXP (obj); -#ifndef SCM_RECKLESS - else if (SCM_NCONSP (obj)) - scm_wrong_type_arg (s_set_source_property_x, 1, obj); -#endif - h = scm_whash_get_handle (scm_source_whash, obj); - if (SCM_WHASHFOUNDP (h)) - p = SCM_WHASHREF (scm_source_whash, h); - else - { - h = scm_whash_create_handle (scm_source_whash, obj); - p = SCM_EOL; - } - if (scm_i_breakpoint == key) - if (SCM_FALSEP (datum)) - CLEARSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p) - ? p - : SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (0, 0, SCM_UNDEFINED, - SCM_UNDEFINED, p))); - else - SETSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p) - ? p - : SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (0, 0, SCM_UNDEFINED, - SCM_UNDEFINED, p))); - else if (scm_i_line == key) - { - if (SCM_NIMP (p) && SRCPROPSP (p)) - SETSRCPROPLINE (p, datum); - else - SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (datum, 0, SCM_UNDEFINED, SCM_UNDEFINED, p)); - } - else if (scm_i_column == key) - { - if (SCM_NIMP (p) && SRCPROPSP (p)) - SETSRCPROPCOL (p, datum); - else - SCM_WHASHSET (scm_source_whash, h, - scm_make_srcprops (0, datum, SCM_UNDEFINED, SCM_UNDEFINED, p)); - } - else if (scm_i_filename == key) - { - if (SCM_NIMP (p) && SRCPROPSP (p)) - SRCPROPFNAME (p) = datum; - else - SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p)); - } - else if (scm_i_filename == key) - { - if (SCM_NIMP (p) && SRCPROPSP (p)) - SRCPROPCOPY (p) = datum; - else - SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p)); - } - else - SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p)); - return SCM_UNSPECIFIED; -} - - -void -scm_init_srcprop () -{ - scm_tc16_srcprops = scm_newsmob (&srcpropssmob); - scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047)); - - scm_i_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED)); - scm_i_copy = SCM_CAR (scm_sysintern ("copy", SCM_UNDEFINED)); - scm_i_line = SCM_CAR (scm_sysintern ("line", SCM_UNDEFINED)); - scm_i_column = SCM_CAR (scm_sysintern ("column", SCM_UNDEFINED)); - scm_i_breakpoint = SCM_CAR (scm_sysintern ("breakpoint", SCM_UNDEFINED)); - - scm_sysintern ("source-whash", scm_source_whash); -#include "srcprop.x" -} - -void -scm_finish_srcprop () -{ - register scm_srcprops_chunk *ptr = srcprops_chunklist, *next; - while (ptr) - { - next = ptr->next; - free ((char *) ptr); - scm_mallocated -= sizeof (scm_srcprops_chunk) - + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1); - ptr = next; - } -} diff --git a/libguile/srcprop.h b/libguile/srcprop.h deleted file mode 100644 index ae9358b0c..000000000 --- a/libguile/srcprop.h +++ /dev/null @@ -1,134 +0,0 @@ -/* classes: h_files */ - -#ifndef SRCPROPH -#define SRCPROPH -/* Copyright (C) 1995,1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include "libguile/__scm.h" - - - -/* {The old whash table interface} - * *fixme* This is a temporary solution until weak hash table access - * has been optimized for speed (which is quite necessary, if they are - * used for recording of source code positions...) - */ - -#define scm_whash_handle SCM - -#define scm_whash_get_handle(whash, key) scm_hash_fn_get_handle (whash, key, scm_ihashq, scm_sloppy_assq, 0) -#define SCM_WHASHFOUNDP(h) ((h) != SCM_BOOL_F) -#define SCM_WHASHREF(whash, handle) SCM_CDR (handle) -#define SCM_WHASHSET(whash, handle, obj) SCM_SETCDR (handle, obj) -#define scm_whash_create_handle(whash, key) scm_hash_fn_create_handle_x (whash, key, SCM_UNSPECIFIED, scm_ihashq, scm_sloppy_assq, 0) -#define scm_whash_lookup(whash, obj) scm_hash_fn_ref (whash, obj, SCM_BOOL_F, scm_ihashq, scm_sloppy_assq, 0) -#define scm_whash_insert(whash, key, obj) \ -{ \ - register SCM w = (whash); \ - SCM_WHASHSET (w, scm_whash_create_handle (w, key), obj); \ -} \ - - -/* {Source properties} - */ - -extern long scm_tc16_srcprops; - -typedef struct scm_srcprops -{ - unsigned long pos; - SCM fname; - SCM copy; - SCM plist; -} scm_srcprops; - -#define SRCPROPS_CHUNKSIZE 2047 /* Number of srcprops per chunk */ -typedef struct scm_srcprops_chunk -{ - struct scm_srcprops_chunk *next; - scm_srcprops srcprops[1]; -} scm_srcprops_chunk; - -#define SRCPROPSP(p) (SCM_TYP16 (p) == scm_tc16_srcprops) -#define SRCPROPBRK(p) ((1L << 16) & SCM_CAR (p) ? SCM_BOOL_T : SCM_BOOL_F) -#define SRCPROPPOS(p) ((scm_srcprops *) SCM_CDR (p))->pos -#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) -#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) -#define SRCPROPFNAME(p) ((scm_srcprops *) SCM_CDR (p))->fname -#define SRCPROPCOPY(p) ((scm_srcprops *) SCM_CDR (p))->copy -#define SRCPROPPLIST(p) ((scm_srcprops *) SCM_CDR (p))->plist -#define SETSRCPROPBRK(p) (SCM_SETOR_CAR (p, (1L << 16))) -#define CLEARSRCPROPBRK(p) SCM_SETAND_CAR (p, ~(1L << 16)) -#define SRCPROPMAKPOS(l,c) (((l) << 12) + (c)) -#define SETSRCPROPPOS(p,l,c) (SRCPROPPOS (p) = SRCPROPMAKPOS (l, c)) -#define SETSRCPROPLINE(p,l) SETSRCPROPPOS (p, l, SRCPROPCOL (p)) -#define SETSRCPROPCOL(p,c) SETSRCPROPPOS (p, SRCPROPLINE (p), c) - -#define SRCBRKP(x) (SCM_NIMP (t.arg1 = scm_whash_lookup (scm_source_whash, (x)))\ - && SRCPROPSP (t.arg1)\ - && (1L << 16) & SCM_CAR (t.arg1)) - -#define PROCTRACEP(x) SCM_NFALSEP (scm_procedure_property (x, scm_i_trace)) - -extern SCM scm_i_filename; -extern SCM scm_i_copy; -extern SCM scm_i_line; -extern SCM scm_i_column; -extern SCM scm_i_breakpoint; - - - - -extern SCM scm_srcprops_to_plist SCM_P ((SCM obj)); -extern SCM scm_make_srcprops SCM_P ((int line, int col, SCM fname, SCM copy, SCM plist)); -extern SCM scm_source_property SCM_P ((SCM obj, SCM key)); -extern SCM scm_set_source_property_x SCM_P ((SCM obj, SCM key, SCM datum)); -extern SCM scm_source_properties SCM_P ((SCM obj)); -extern SCM scm_set_source_properties_x SCM_P ((SCM obj, SCM props)); -extern void scm_finish_srcprop SCM_P ((void)); -extern void scm_init_srcprop SCM_P ((void)); - -#endif /* SRCPROPH */ diff --git a/libguile/stackchk.c b/libguile/stackchk.c deleted file mode 100644 index 92846170f..000000000 --- a/libguile/stackchk.c +++ /dev/null @@ -1,104 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" - -#include "stackchk.h" - - -/* {Stack Checking} - */ - -#ifdef STACK_CHECKING -int scm_stack_checking_enabled_p; - -SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow"); - -void -scm_report_stack_overflow () -{ - scm_stack_checking_enabled_p = 0; - scm_error (scm_stack_overflow_key, - NULL, - "Stack overflow", - SCM_BOOL_F, - SCM_BOOL_F); -} - -#endif - -long -scm_stack_size (start) - SCM_STACKITEM *start; -{ - SCM_STACKITEM stack; -#ifdef SCM_STACK_GROWS_UP - return &stack - start; -#else - return start - &stack; -#endif /* def SCM_STACK_GROWS_UP */ -} - - -void -scm_stack_report () -{ - SCM_STACKITEM stack; - scm_intprint (scm_stack_size (SCM_BASE (scm_rootcont)) * sizeof (SCM_STACKITEM), - 16, scm_cur_errp); - scm_gen_puts (scm_regular_string, " of stack: 0x", scm_cur_errp); - scm_intprint ((long) SCM_BASE (scm_rootcont), 16, scm_cur_errp); - scm_gen_puts (scm_regular_string, " - 0x", scm_cur_errp); - scm_intprint ((long) &stack, 16, scm_cur_errp); - scm_gen_puts (scm_regular_string, "\n", scm_cur_errp); -} - - - - -void -scm_init_stackchk () -{ -#include "stackchk.x" -} diff --git a/libguile/stackchk.h b/libguile/stackchk.h deleted file mode 100644 index 6e6a358fc..000000000 --- a/libguile/stackchk.h +++ /dev/null @@ -1,92 +0,0 @@ -/* classes: h_files */ - -#ifndef STACKCHKH -#define STACKCHKH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - -#include "libguile/continuations.h" -#ifdef DEBUG_EXTENSIONS -#include "libguile/debug.h" -#endif - - -/* With debug extensions we have the possibility to use the debug options - * to disable stack checking. - */ -#ifdef DEBUG_EXTENSIONS -#define SCM_STACK_CHECKING_P SCM_STACK_LIMIT -#else -/* *fixme* This option should be settable also without debug extensions. */ -#define SCM_STACK_LIMIT 100000 -#define SCM_STACK_CHECKING_P 1 -#endif - -#ifdef STACK_CHECKING -# ifdef SCM_STACK_GROWS_UP -# define SCM_STACK_OVERFLOW_P(s)\ - (s - SCM_BASE (scm_rootcont) > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM)) -# else -# define SCM_STACK_OVERFLOW_P(s)\ - (SCM_BASE (scm_rootcont) - s > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM)) -# endif -# define SCM_CHECK_STACK\ - {\ - SCM_STACKITEM stack;\ - if (SCM_STACK_OVERFLOW_P (&stack) && scm_stack_checking_enabled_p)\ - scm_report_stack_overflow ();\ - } -#else -# define SCM_CHECK_STACK /**/ -#endif /* STACK_CHECKING */ - -extern int scm_stack_checking_enabled_p; - - - -extern void scm_report_stack_overflow SCM_P ((void)); -extern long scm_stack_size SCM_P ((SCM_STACKITEM *start)); -extern void scm_stack_report SCM_P ((void)); -extern void scm_init_stackchk SCM_P ((void)); - -#endif /* STACKCHKH */ diff --git a/libguile/stacks.h b/libguile/stacks.h deleted file mode 100644 index 3cbcb28be..000000000 --- a/libguile/stacks.h +++ /dev/null @@ -1,135 +0,0 @@ -/* classes: h_files */ - -#ifndef STACKSH -#define STACKSH -/* Copyright (C) 1995,1996 Mikael Djurfeldt - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - * - * The author can be reached at djurfeldt@nada.kth.se - * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN - */ - - -#include "libguile/__scm.h" - -/* {Frames and stacks} - */ - -typedef struct scm_info_frame { - SCM flags; - SCM source; - SCM proc; - SCM args; -} scm_info_frame; -#define SCM_FRAME_N_SLOTS (sizeof (scm_info_frame) / sizeof (SCM)) - -#define SCM_STACK(obj) ((scm_stack *) SCM_STRUCT_DATA (obj)) -#define SCM_STACK_LAYOUT "pwuourpW" -typedef struct scm_stack { - SCM id; /* Stack id */ - scm_info_frame *frames; /* Info frames */ - unsigned int length; /* Stack length */ - unsigned int tail_length; - scm_info_frame tail[1]; -} scm_stack; - -extern SCM scm_stack_type; - -#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE (obj) == scm_stack_type) -#define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length) - -#define SCM_FRAMEP(obj) (SCM_CONSP (obj) \ - && SCM_NIMP (SCM_CAR (obj)) \ - && SCM_STACKP (SCM_CAR (obj)) \ - && SCM_INUMP (SCM_CDR (obj))) \ - - -#define SCM_FRAME_REF(frame, slot) \ -(SCM_STACK (SCM_CAR (frame)) -> frames[SCM_INUM (SCM_CDR (frame))].slot) \ - -#define SCM_FRAME_NUMBER(frame) \ -(SCM_BACKWARDS_P \ - ? SCM_INUM (SCM_CDR (frame)) \ - : (SCM_STACK_LENGTH (SCM_CAR (frame)) \ - - SCM_INUM (SCM_CDR (frame)) \ - - 1)) \ - -#define SCM_FRAME_FLAGS(frame) SCM_FRAME_REF (frame, flags) -#define SCM_FRAME_SOURCE(frame) SCM_FRAME_REF (frame, source) -#define SCM_FRAME_PROC(frame) SCM_FRAME_REF (frame, proc) -#define SCM_FRAME_ARGS(frame) SCM_FRAME_REF (frame, args) -#define SCM_FRAME_PREV(frame) scm_frame_previous (frame) -#define SCM_FRAME_NEXT(frame) scm_frame_next (frame) - -#define SCM_FRAMEF_VOID (1L << 2) -#define SCM_FRAMEF_REAL (1L << 3) -#define SCM_FRAMEF_PROC (1L << 4) -#define SCM_FRAMEF_EVAL_ARGS (1L << 5) -#define SCM_FRAMEF_OVERFLOW (1L << 6) - -#define SCM_FRAME_VOID_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_VOID) -#define SCM_FRAME_REAL_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_REAL) -#define SCM_FRAME_PROC_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_PROC) -#define SCM_FRAME_EVAL_ARGS_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_EVAL_ARGS) -#define SCM_FRAME_OVERFLOW_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_OVERFLOW) - - - -SCM scm_stack_p SCM_P ((SCM obj)); -SCM scm_make_stack SCM_P ((SCM args)); -SCM scm_stack_ref SCM_P ((SCM stack, SCM i)); -SCM scm_stack_length SCM_P ((SCM stack)); - -SCM scm_frame_p SCM_P ((SCM obj)); -SCM scm_last_stack_frame SCM_P ((SCM obj)); -SCM scm_frame_number SCM_P ((SCM frame)); -SCM scm_frame_source SCM_P ((SCM frame)); -SCM scm_frame_procedure SCM_P ((SCM frame)); -SCM scm_frame_arguments SCM_P ((SCM frame)); -SCM scm_frame_previous SCM_P ((SCM frame)); -SCM scm_frame_next SCM_P ((SCM frame)); -SCM scm_frame_real_p SCM_P ((SCM frame)); -SCM scm_frame_procedure_p SCM_P ((SCM frame)); -SCM scm_frame_evaluating_args_p SCM_P ((SCM frame)); -SCM scm_frame_overflow_p SCM_P ((SCM frame)); - -void scm_init_stacks SCM_P ((void)); - -#endif /* STACKSH */ diff --git a/libguile/stamp-h.in b/libguile/stamp-h.in deleted file mode 100644 index e69de29bb..000000000 --- a/libguile/stamp-h.in +++ /dev/null diff --git a/libguile/stime.c b/libguile/stime.c deleted file mode 100644 index efc9d172f..000000000 --- a/libguile/stime.c +++ /dev/null @@ -1,206 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" - -#include "stime.h" - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - - -# ifdef HAVE_SYS_TYPES_H -# include <sys/types.h> -# endif - -# ifdef TIME_WITH_SYS_TIME -# include <sys/time.h> -# include <time.h> -# else -# ifdef HAVE_SYS_TIME_H -# include <sys/time.h> -# else -# ifdef HAVE_TIME_H -# include <time.h> -# endif -# endif -# endif - -# ifdef HAVE_SYS_TIMES_H -# include <sys/times.h> -# else -# ifdef HAVE_SYS_TIMEB_H -# include <sys/timeb.h> -# endif -# endif - -#ifdef CLK_TCK -# define CLKTCK CLK_TCK -# ifdef CLOCKS_PER_SEC -# ifdef unix -# ifndef ARM_ULIB -# include <sys/times.h> -# endif -# define LACK_CLOCK - /* This is because clock() might be POSIX rather than ANSI. - This occurs on HP-UX machines */ -# endif -# endif -#else -# ifdef CLOCKS_PER_SEC -# define CLKTCK CLOCKS_PER_SEC -# else -# define LACK_CLOCK -# define CLKTCK 60 -# endif -#endif - - -# ifdef HAVE_FTIME -# include <sys/timeb.h> -# endif - - -#ifdef __STDC__ -# define timet time_t -#else -# define timet long -#endif - -#ifdef HAVE_TIMES -static -long mytime() -{ - struct tms time_buffer; - times(&time_buffer); - return time_buffer.tms_utime + time_buffer.tms_stime; -} -#else -# ifdef LACK_CLOCK -# define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK) -# else -# define mytime clock -# endif -#endif - - - -#ifdef HAVE_FTIME - -extern int ftime (struct timeb *); - -struct timeb scm_your_base = {0}; -SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); -SCM -scm_get_internal_real_time() -{ - struct timeb time_buffer; - long tmp; - ftime(&time_buffer); - time_buffer.time -= scm_your_base.time; - tmp = time_buffer.millitm - scm_your_base.millitm; - tmp = time_buffer.time*1000L + tmp; - tmp *= CLKTCK; - tmp /= 1000; - return SCM_MAKINUM(tmp); -} - -#else - -timet scm_your_base = 0; -SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); -SCM -scm_get_internal_real_time() -{ - return SCM_MAKINUM((time((timet*)0) - scm_your_base) * (int)CLKTCK); -} -#endif - - - -static long scm_my_base = 0; - -SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time); -SCM -scm_get_internal_run_time() -{ - return SCM_MAKINUM(mytime()-scm_my_base); -} - -SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time); -SCM -scm_current_time() -{ - timet timv = time((timet*)0); - SCM ans; - ans = scm_ulong2num(timv); - return SCM_BOOL_F==ans ? SCM_MAKINUM(timv) : ans; -} - -long -scm_time_in_msec(x) - long x; -{ - if (CLKTCK==60) return (x*50)/3; - else - return (CLKTCK < 1000 ? x*(1000L/(long)CLKTCK) : (x*1000L)/(long)CLKTCK); -} - -void -scm_init_stime() -{ - scm_sysintern("internal-time-units-per-second", - SCM_MAKINUM((long)CLKTCK)); - -#ifdef HAVE_FTIME - if (!scm_your_base.time) ftime(&scm_your_base); -#else - if (!scm_your_base) time(&scm_your_base); -#endif - - if (!scm_my_base) scm_my_base = mytime(); - -#include "stime.x" -} - diff --git a/libguile/stime.h b/libguile/stime.h deleted file mode 100644 index 54a093bc3..000000000 --- a/libguile/stime.h +++ /dev/null @@ -1,56 +0,0 @@ -/* classes: h_files */ - -#ifndef TIMEH -#define TIMEH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -extern SCM scm_get_internal_real_time SCM_P ((void)); -extern SCM scm_get_internal_run_time SCM_P ((void)); -extern SCM scm_current_time SCM_P ((void)); -extern long scm_time_in_msec SCM_P ((long x)); -extern void scm_init_stime SCM_P ((void)); - -#endif /* TIMEH */ diff --git a/libguile/strerror.c b/libguile/strerror.c deleted file mode 100644 index 4723d04e8..000000000 --- a/libguile/strerror.c +++ /dev/null @@ -1,32 +0,0 @@ -/* Turning errno values into English error messages. - Copyright (C) 1985, 86, 87, 88, 93, 94, 95 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - - -char * -strerror (errnum) - int errnum; -{ - extern char *sys_errlist[]; - extern int sys_nerr; - - if (errnum >= 0 && errnum < sys_nerr) - return sys_errlist[errnum]; - return (char *) "Unknown error"; -} diff --git a/libguile/strings.c b/libguile/strings.c deleted file mode 100644 index e3c24406b..000000000 --- a/libguile/strings.c +++ /dev/null @@ -1,407 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "strings.h" - - -/* {Strings} - */ - -SCM_PROC(s_string_p, "string?", 1, 0, 0, scm_string_p); - -SCM -scm_string_p (x) - SCM x; -{ - if (SCM_IMP (x)) - return SCM_BOOL_F; - return SCM_STRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_read_only_string_p, "read-only-string?", 1, 0, 0, scm_read_only_string_p); - -SCM -scm_read_only_string_p (x) - SCM x; -{ - if (SCM_IMP (x)) - return SCM_BOOL_F; - return SCM_ROSTRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_list_to_string, "list->string", 1, 0, 0, scm_string); -SCM_PROC(s_string, "string", 0, 0, 1, scm_string); - -SCM -scm_string (chrs) - SCM chrs; -{ - SCM res; - register unsigned char *data; - long i; - long len; - SCM_DEFER_INTS; - i = scm_ilength (chrs); - if (i < 0) - { - SCM_ALLOW_INTS; - SCM_ASSERT (0, chrs, SCM_ARG1, s_string); - } - len = 0; - { - SCM s; - - for (len = 0, s = chrs; s != SCM_EOL; s = SCM_CDR (s)) - if (SCM_ICHRP (SCM_CAR (s))) - len += 1; - else if (SCM_NIMP (SCM_CAR (s)) && SCM_ROSTRINGP (SCM_CAR (s))) - len += SCM_ROLENGTH (SCM_CAR (s)); - else - { - SCM_ALLOW_INTS; - SCM_ASSERT (0, s, SCM_ARG1, s_string); - } - } - res = scm_makstr (len, 0); - data = SCM_UCHARS (res); - for (;SCM_NNULLP (chrs);chrs = SCM_CDR (chrs)) - { - if (SCM_ICHRP (SCM_CAR (chrs))) - *data++ = SCM_ICHR (SCM_CAR (chrs)); - else - { - int l; - char * c; - l = SCM_ROLENGTH (SCM_CAR (chrs)); - c = SCM_ROUCHARS (SCM_CAR (chrs)); - while (l) - { - --l; - *data++ = *c++; - } - } - } - SCM_ALLOW_INTS; - return res; -} - - -SCM -scm_makstr (len, slots) - long len; - int slots; -{ - SCM s; - SCM * mem; - SCM_NEWCELL (s); - --slots; - SCM_REDEFER_INTS; - mem = (SCM *)scm_must_malloc (sizeof (SCM) * (slots + 1) + len + 1, - s_string); - if (slots >= 0) - { - int x; - mem[slots] = (SCM)mem; - for (x = 0; x < slots; ++x) - mem[x] = SCM_BOOL_F; - } - SCM_SETCHARS (s, (char *) (mem + slots + 1)); - SCM_SETLENGTH (s, len, scm_tc7_string); - SCM_REALLOW_INTS; - SCM_CHARS (s)[len] = 0; - return s; -} - -/* converts C scm_array of strings to SCM scm_list of strings. */ -/* If argc < 0, a null terminated scm_array is assumed. */ - -SCM -scm_makfromstrs (argc, argv) - int argc; - char **argv; -{ - int i = argc; - SCM lst = SCM_EOL; - if (0 > i) - for (i = 0; argv[i]; i++); - while (i--) - lst = scm_cons (scm_makfromstr (argv[i], (scm_sizet) strlen (argv[i]), 0), lst); - return lst; -} - - - -SCM -scm_take0str (it) - char * it; -{ - SCM answer; - SCM_NEWCELL (answer); - SCM_DEFER_INTS; - SCM_SETLENGTH (answer, strlen (it), scm_tc7_string); - SCM_SETCHARS (answer, it); - SCM_ALLOW_INTS; - return answer; -} - - -SCM -scm_makfromstr (src, len, slots) - const char *src; - scm_sizet len; - int slots; -{ - SCM s; - register char *dst; - s = scm_makstr ((long) len, slots); - dst = SCM_CHARS (s); - while (len--) - *dst++ = *src++; - return s; -} - - - -SCM -scm_makfrom0str (src) - const char *src; -{ - if (!src) return SCM_BOOL_F; - return scm_makfromstr (src, (scm_sizet) strlen (src), 0); -} - - -SCM -scm_makfrom0str_opt (src) - const char *src; -{ - return scm_makfrom0str (src); -} - - - - -SCM_PROC(s_make_string, "make-string", 1, 1, 0, scm_make_string); - -SCM -scm_make_string (k, chr) - SCM k; - SCM chr; -{ - SCM res; - register unsigned char *dst; - register long i; - SCM_ASSERT (SCM_INUMP (k) && (k >= 0), k, SCM_ARG1, s_make_string); - i = SCM_INUM (k); - res = scm_makstr (i, 0); - dst = SCM_UCHARS (res); - if SCM_ICHRP (chr) - { - char c = SCM_ICHR (chr); - for (i--;i >= 0;i--) - { - dst[i] = c; - } - } - return res; -} - -SCM_PROC(s_string_length, "string-length", 1, 0, 0, scm_string_length); - -SCM -scm_string_length (str) - SCM str; -{ - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_length); - return SCM_MAKINUM (SCM_ROLENGTH (str)); -} - -SCM_PROC(s_string_ref, "string-ref", 1, 1, 0, scm_string_ref); - -SCM -scm_string_ref (str, k) - SCM str; - SCM k; -{ - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_ref); - if (k == SCM_UNDEFINED) - k = SCM_MAKINUM (0); - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_ref); - SCM_ASSERT (SCM_INUM (k) < SCM_ROLENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_ref); - return SCM_MAKICHR (SCM_ROUCHARS (str)[SCM_INUM (k)]); -} - -SCM_PROC(s_string_set_x, "string-set!", 3, 0, 0, scm_string_set_x); - -SCM -scm_string_set_x (str, k, chr) - SCM str; - SCM k; - SCM chr; -{ - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_set_x); - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_set_x); - SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG3, s_string_set_x); - SCM_ASSERT (SCM_INUM (k) < SCM_LENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_set_x); - SCM_UCHARS (str)[SCM_INUM (k)] = SCM_ICHR (chr); - return SCM_UNSPECIFIED; -} - - - -SCM_PROC(s_substring, "substring", 2, 1, 0, scm_substring); - -SCM -scm_substring (str, start, end) - SCM str; - SCM start; - SCM end; -{ - long l; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), - str, SCM_ARG1, s_substring); - SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring); - if (end == SCM_UNDEFINED) - end = SCM_MAKINUM (SCM_ROLENGTH (str)); - SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring); - SCM_ASSERT (SCM_INUM (start) <= SCM_ROLENGTH (str), start, SCM_OUTOFRANGE, s_substring); - SCM_ASSERT (SCM_INUM (end) <= SCM_ROLENGTH (str), end, SCM_OUTOFRANGE, s_substring); - l = SCM_INUM (end)-SCM_INUM (start); - SCM_ASSERT (l >= 0, SCM_MAKINUM (l), SCM_OUTOFRANGE, s_substring); - return scm_makfromstr (&SCM_ROCHARS (str)[SCM_INUM (start)], (scm_sizet)l, 0); -} - -SCM_PROC(s_string_append, "string-append", 0, 0, 1, scm_string_append); - -SCM -scm_string_append (args) - SCM args; -{ - SCM res; - register long i = 0; - register SCM l, s; - register unsigned char *data; - for (l = args;SCM_NIMP (l);) { - SCM_ASSERT (SCM_CONSP (l), l, SCM_ARGn, s_string_append); - s = SCM_CAR (l); - SCM_ASSERT (SCM_NIMP (s) && SCM_ROSTRINGP (s), - s, SCM_ARGn, s_string_append); - i += SCM_ROLENGTH (s); - l = SCM_CDR (l); - } - SCM_ASSERT (SCM_NULLP (l), args, SCM_ARGn, s_string_append); - res = scm_makstr (i, 0); - data = SCM_UCHARS (res); - for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) { - s = SCM_CAR (l); - for (i = 0;i<SCM_ROLENGTH (s);i++) *data++ = SCM_ROUCHARS (s)[i]; - } - return res; -} - -SCM_PROC(s_make_shared_substring, "make-shared-substring", 1, 2, 0, scm_make_shared_substring); - -SCM -scm_make_shared_substring (str, frm, to) - SCM str; - SCM frm; - SCM to; -{ - long f; - long t; - SCM answer; - SCM len_str; - - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_make_shared_substring); - - if (frm == SCM_UNDEFINED) - frm = SCM_MAKINUM (0); - else - SCM_ASSERT (SCM_INUMP (frm), frm, SCM_ARG2, s_make_shared_substring); - - if (to == SCM_UNDEFINED) - to = SCM_MAKINUM (SCM_ROLENGTH (str)); - else - SCM_ASSERT (SCM_INUMP (to), to, SCM_ARG3, s_make_shared_substring); - - f = SCM_INUM (frm); - t = SCM_INUM (to); - SCM_ASSERT ((f >= 0), frm, SCM_OUTOFRANGE, s_make_shared_substring); - SCM_ASSERT ((f <= t) && (t <= SCM_ROLENGTH (str)), to, SCM_OUTOFRANGE, s_make_shared_substring); - - SCM_NEWCELL (answer); - SCM_NEWCELL (len_str); - - SCM_DEFER_INTS; - if (SCM_SUBSTRP (str)) - { - long offset; - offset = SCM_INUM (SCM_SUBSTR_OFFSET (str)); - f += offset; - t += offset; - SCM_SETCAR (len_str, SCM_MAKINUM (f)); - SCM_SETCDR (len_str, SCM_SUBSTR_STR (str)); - SCM_SETCDR (answer, len_str); - SCM_SETLENGTH (answer, t - f, scm_tc7_substring); - } - else - { - SCM_SETCAR (len_str, SCM_MAKINUM (f)); - SCM_SETCDR (len_str, str); - SCM_SETCDR (answer, len_str); - SCM_SETLENGTH (answer, t - f, scm_tc7_substring); - } - SCM_ALLOW_INTS; - return answer; -} - - -void -scm_init_strings () -{ -#include "strings.x" -} - diff --git a/libguile/strings.h b/libguile/strings.h deleted file mode 100644 index 93f5a6e43..000000000 --- a/libguile/strings.h +++ /dev/null @@ -1,79 +0,0 @@ -/* classes: h_files */ - -#ifndef STRINGSH -#define STRINGSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - -#define SCM_STRINGP(x) (SCM_TYP7S(x)==scm_tc7_string) -#define SCM_NSTRINGP(x) (!SCM_STRINGP(x)) - - - - -extern SCM scm_string_p SCM_P ((SCM x)); -extern SCM scm_read_only_string_p SCM_P ((SCM x)); -extern SCM scm_string SCM_P ((SCM chrs)); -extern SCM scm_makstr SCM_P ((long len, int slots)); -extern SCM scm_makfromstrs SCM_P ((int argc, char **argv)); -extern SCM scm_take0str SCM_P ((char * it)); -extern SCM scm_makfromstr SCM_P ((const char *src, scm_sizet len, int slots)); -extern SCM scm_makfrom0str SCM_P ((const char *src)); -extern SCM scm_makfrom0str_opt SCM_P ((const char *src)); -extern SCM scm_make_string SCM_P ((SCM k, SCM chr)); -extern SCM scm_string_length SCM_P ((SCM str)); -extern SCM scm_string_ref SCM_P ((SCM str, SCM k)); -extern SCM scm_string_set_x SCM_P ((SCM str, SCM k, SCM chr)); -extern SCM scm_substring SCM_P ((SCM str, SCM start, SCM end)); -extern SCM scm_string_append SCM_P ((SCM args)); -extern SCM scm_make_shared_substring SCM_P ((SCM str, SCM frm, SCM to)); -extern void scm_init_strings SCM_P ((void)); - -#endif /* STRINGSH */ diff --git a/libguile/strop.c b/libguile/strop.c deleted file mode 100644 index 2f73f9724..000000000 --- a/libguile/strop.c +++ /dev/null @@ -1,325 +0,0 @@ -/* classes: src_files */ - -/* Copyright (C) 1994 Free Software Foundation, Inc. - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2, or (at your option) -any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with this software; see the file COPYING. If not, write to -the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ - - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "strop.h" - - - -int -scm_i_index (str, chr, sub_start, sub_end, pos, pos2, pos3, pos4, why) - SCM * str; - SCM chr; - SCM sub_start; - SCM sub_end; - int pos; - int pos2; - int pos3; - int pos4; - char * why; -{ - unsigned char * p; - int x; - int bound; - int ch; - - SCM_ASSERT (SCM_NIMP (*str) && SCM_ROSTRINGP (*str), *str, pos, why); - SCM_ASSERT (SCM_ICHRP (chr), chr, pos2, why); - - if (sub_start == SCM_BOOL_F) - sub_start = SCM_MAKINUM (0); - else - SCM_ASSERT ( SCM_INUMP (sub_start) - && (0 <= SCM_INUM (sub_start)) - && (SCM_INUM (sub_start) <= SCM_ROLENGTH (*str)), - sub_start, pos3, why); - - if (sub_end == SCM_BOOL_F) - sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str)); - else - SCM_ASSERT ( SCM_INUMP (sub_end) - && (SCM_INUM (sub_start) <= SCM_INUM (sub_end)) - && (SCM_INUM (sub_end) <= SCM_ROLENGTH (*str)), - sub_end, pos4, why); - - p = (unsigned char *)SCM_ROCHARS (*str) + SCM_INUM (sub_start); - bound = SCM_INUM (sub_end); - ch = SCM_ICHR (chr); - - for (x = SCM_INUM (sub_start); x < bound; ++x, ++p) - if (*p == ch) - return x; - - return -1; -} - - -int -scm_i_rindex (str, chr, sub_start, sub_end, pos, pos2, pos3, pos4, why) - SCM * str; - SCM chr; - SCM sub_start; - SCM sub_end; - int pos; - int pos2; - int pos3; - int pos4; - char * why; -{ - unsigned char * p; - int x; - int upper_bound; - int lower_bound; - int ch; - - SCM_ASSERT (SCM_NIMP (*str) && SCM_ROSTRINGP (*str), *str, pos, why); - SCM_ASSERT (SCM_ICHRP (chr), chr, pos2, why); - - if (sub_start == SCM_BOOL_F) - sub_start = SCM_MAKINUM (0); - else - SCM_ASSERT ( SCM_INUMP (sub_start) - && (0 <= SCM_INUM (sub_start)) - && (SCM_INUM (sub_start) <= SCM_ROLENGTH (*str)), - sub_start, pos3, why); - - if (sub_end == SCM_BOOL_F) - sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str)); - else - SCM_ASSERT ( SCM_INUMP (sub_end) - && (SCM_INUM (sub_start) <= SCM_INUM (sub_end)) - && (SCM_INUM (sub_end) <= SCM_ROLENGTH (*str)), - sub_end, pos4, why); - - upper_bound = SCM_INUM (sub_end); - lower_bound = SCM_INUM (sub_start); - p = upper_bound - 1 + (unsigned char *)SCM_ROCHARS (*str); - ch = SCM_ICHR (chr); - for (x = upper_bound - 1; x >= lower_bound; --x, --p) - if (*p == ch) - return x; - - return -1; -} - - -SCM_PROC(s_string_index, "string-index", 2, 2, 0, scm_string_index); - -SCM -scm_string_index (str, chr, frm, to) - SCM str; - SCM chr; - SCM frm; - SCM to; -{ - int pos; - - if (frm == SCM_UNDEFINED) - frm = SCM_BOOL_F; - if (to == SCM_UNDEFINED) - to = SCM_BOOL_F; - pos = scm_i_index (&str, chr, frm, to, SCM_ARG1, SCM_ARG2, SCM_ARG3, SCM_ARG4, s_string_index); - return (pos < 0 - ? SCM_BOOL_F - : SCM_MAKINUM (pos)); -} - -SCM_PROC(s_string_rindex, "string-rindex", 2, 2, 0, scm_string_rindex); - -SCM -scm_string_rindex (str, chr, frm, to) - SCM str; - SCM chr; - SCM frm; - SCM to; -{ - int pos; - - if (frm == SCM_UNDEFINED) - frm = SCM_BOOL_F; - if (to == SCM_UNDEFINED) - to = SCM_BOOL_F; - pos = scm_i_rindex (&str, chr, frm, to, SCM_ARG1, SCM_ARG2, SCM_ARG3, SCM_ARG4, s_string_index); - return (pos < 0 - ? SCM_BOOL_F - : SCM_MAKINUM (pos)); -} - - - - - - -SCM_PROC(s_substring_move_left_x, "substring-move-left!", 2, 0, 1, scm_substring_move_left_x); - -SCM -scm_substring_move_left_x (str1, start1, args) - SCM str1; - SCM start1; - SCM args; -{ - SCM end1, str2, start2; - long i, j, e; - SCM_ASSERT (3==scm_ilength (args), scm_makfrom0str (s_substring_move_left_x), - SCM_WNA, NULL); - end1 = SCM_CAR (args); args = SCM_CDR (args); - str2 = SCM_CAR (args); args = SCM_CDR (args); - start2 = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (str1) && SCM_STRINGP (str1), str1, SCM_ARG1, s_substring_move_left_x); - SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_substring_move_left_x); - SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_substring_move_left_x); - SCM_ASSERT (SCM_NIMP (str2) && SCM_STRINGP (str2), str2, SCM_ARG4, s_substring_move_left_x); - SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_substring_move_left_x); - i = SCM_INUM (start1), j = SCM_INUM (start2), e = SCM_INUM (end1); - SCM_ASSERT (i <= SCM_LENGTH (str1) && i >= 0, start1, SCM_OUTOFRANGE, s_substring_move_left_x); - SCM_ASSERT (j <= SCM_LENGTH (str2) && j >= 0, start2, SCM_OUTOFRANGE, s_substring_move_left_x); - SCM_ASSERT (e <= SCM_LENGTH (str1) && e >= 0, end1, SCM_OUTOFRANGE, s_substring_move_left_x); - SCM_ASSERT (e-i+j <= SCM_LENGTH (str2), start2, SCM_OUTOFRANGE, s_substring_move_left_x); - while (i<e) SCM_CHARS (str2)[j++] = SCM_CHARS (str1)[i++]; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_substring_move_right_x, "substring-move-right!", 2, 0, 1, scm_substring_move_right_x); - -SCM -scm_substring_move_right_x (str1, start1, args) - SCM str1; - SCM start1; - SCM args; -{ - SCM end1, str2, start2; - long i, j, e; - SCM_ASSERT (3==scm_ilength (args), - scm_makfrom0str (s_substring_move_right_x), SCM_WNA, NULL); - end1 = SCM_CAR (args); args = SCM_CDR (args); - str2 = SCM_CAR (args); args = SCM_CDR (args); - start2 = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (str1) && SCM_STRINGP (str1), str1, SCM_ARG1, s_substring_move_right_x); - SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_substring_move_right_x); - SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_substring_move_right_x); - SCM_ASSERT (SCM_NIMP (str2) && SCM_STRINGP (str2), str2, SCM_ARG4, s_substring_move_right_x); - SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_substring_move_right_x); - i = SCM_INUM (start1), j = SCM_INUM (start2), e = SCM_INUM (end1); - SCM_ASSERT (i <= SCM_LENGTH (str1) && i >= 0, start1, SCM_OUTOFRANGE, s_substring_move_right_x); - SCM_ASSERT (j <= SCM_LENGTH (str2) && j >= 0, start2, SCM_OUTOFRANGE, s_substring_move_right_x); - SCM_ASSERT (e <= SCM_LENGTH (str1) && e >= 0, end1, SCM_OUTOFRANGE, s_substring_move_right_x); - SCM_ASSERT ((j = e-i+j) <= SCM_LENGTH (str2), start2, SCM_OUTOFRANGE, s_substring_move_right_x); - while (i<e) SCM_CHARS (str2)[--j] = SCM_CHARS (str1)[--e]; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_substring_fill_x, "substring-fill!", 2, 0, 1, scm_substring_fill_x); - -SCM -scm_substring_fill_x (str, start, args) - SCM str; - SCM start; - SCM args; -{ - SCM end, fill; - long i, e; - char c; - SCM_ASSERT (2==scm_ilength (args), scm_makfrom0str (s_substring_fill_x), - SCM_WNA, NULL); - end = SCM_CAR (args); args = SCM_CDR (args); - fill = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_substring_fill_x); - SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring_fill_x); - SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring_fill_x); - SCM_ASSERT (SCM_ICHRP (fill), fill, SCM_ARG4, s_substring_fill_x); - i = SCM_INUM (start), e = SCM_INUM (end);c = SCM_ICHR (fill); - SCM_ASSERT (i <= SCM_LENGTH (str) && i >= 0, start, SCM_OUTOFRANGE, s_substring_fill_x); - SCM_ASSERT (e <= SCM_LENGTH (str) && e >= 0, end, SCM_OUTOFRANGE, s_substring_fill_x); - while (i<e) SCM_CHARS (str)[i++] = c; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_string_null_p, "string-null?", 1, 0, 0, scm_string_null_p); - -SCM -scm_string_null_p (str) - SCM str; -{ - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_null_p); - return (SCM_ROLENGTH (str) - ? SCM_BOOL_F - : SCM_BOOL_T); -} - - -SCM_PROC(s_string_to_list, "string->list", 1, 0, 0, scm_string_to_list); - -SCM -scm_string_to_list (str) - SCM str; -{ - long i; - SCM res = SCM_EOL; - unsigned char *src; - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_to_list); - src = SCM_ROUCHARS (str); - for (i = SCM_ROLENGTH (str)-1;i >= 0;i--) res = scm_cons ((SCM)SCM_MAKICHR (src[i]), res); - return res; -} - - - -SCM_PROC(s_string_copy, "string-copy", 1, 0, 0, scm_string_copy); - -SCM -scm_string_copy (str) - SCM str; -{ - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_copy); - return scm_makfromstr (SCM_CHARS (str), (scm_sizet)SCM_LENGTH (str), 0); -} - - -SCM_PROC(s_string_fill_x, "string-fill!", 2, 0, 0, scm_string_fill_x); - -SCM -scm_string_fill_x (str, chr) - SCM str; - SCM chr; -{ - register char *dst, c; - register long k; - SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_fill_x); - SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, s_string_fill_x); - c = SCM_ICHR (chr); - dst = SCM_CHARS (str); - for (k = SCM_LENGTH (str)-1;k >= 0;k--) dst[k] = c; - return SCM_UNSPECIFIED; -} - - - -void -scm_init_strop () -{ -#include "strop.x" -} - diff --git a/libguile/strop.h b/libguile/strop.h deleted file mode 100644 index fea23d79c..000000000 --- a/libguile/strop.h +++ /dev/null @@ -1,65 +0,0 @@ -/* classes: h_files */ - -#ifndef STROPH -#define STROPH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - -extern int scm_i_index SCM_P ((SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why)); -extern int scm_i_rindex SCM_P ((SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why)); -extern SCM scm_string_index SCM_P ((SCM str, SCM chr, SCM frm, SCM to)); -extern SCM scm_string_rindex SCM_P ((SCM str, SCM chr, SCM frm, SCM to)); -extern SCM scm_substring_move_left_x SCM_P ((SCM str1, SCM start1, SCM args)); -extern SCM scm_substring_move_right_x SCM_P ((SCM str1, SCM start1, SCM args)); -extern SCM scm_substring_fill_x SCM_P ((SCM str, SCM start, SCM args)); -extern SCM scm_string_null_p SCM_P ((SCM str)); -extern SCM scm_string_to_list SCM_P ((SCM str)); -extern SCM scm_string_copy SCM_P ((SCM str)); -extern SCM scm_string_fill_x SCM_P ((SCM str, SCM chr)); -extern void scm_init_strop SCM_P ((void)); - -#endif /* STROPH */ diff --git a/libguile/strorder.c b/libguile/strorder.c deleted file mode 100644 index a4fe03daa..000000000 --- a/libguile/strorder.c +++ /dev/null @@ -1,224 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "strorder.h" - - -SCM_PROC1 (s_string_equal_p, "string=?", scm_tc7_rpsubr, scm_string_equal_p); - -SCM -scm_string_equal_p (s1, s2) - SCM s1; - SCM s2; -{ - register scm_sizet i; - register unsigned char *c1, *c2; - SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_equal_p); - SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_equal_p); - - i = SCM_ROLENGTH (s2); - if (SCM_ROLENGTH (s1) != i) - { - return SCM_BOOL_F; - } - c1 = SCM_ROUCHARS (s1); - c2 = SCM_ROUCHARS (s2); - while (0 != i--) - if (*c1++ != *c2++) - return SCM_BOOL_F; - return SCM_BOOL_T; -} - -SCM_PROC1 (s_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, scm_string_ci_equal_p); - -SCM -scm_string_ci_equal_p (s1, s2) - SCM s1; - SCM s2; -{ - register scm_sizet i; - register unsigned char *c1, *c2; - SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_ci_equal_p); - SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_ci_equal_p); - i = SCM_ROLENGTH (s2); - if (SCM_ROLENGTH (s1) != i) - { - return SCM_BOOL_F; - } - c1 = SCM_ROUCHARS (s1); - c2 = SCM_ROUCHARS (s2); - while (0 != i--) - if (scm_upcase(*c1++) != scm_upcase(*c2++)) - return SCM_BOOL_F; - return SCM_BOOL_T; -} - -SCM_PROC1 (s_string_less_p, "string<?", scm_tc7_rpsubr, scm_string_less_p); - -SCM -scm_string_less_p (s1, s2) - SCM s1; - SCM s2; -{ - register scm_sizet i, len, s2len; - register unsigned char *c1, *c2; - register int c; - - SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_less_p); - SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_less_p); - len = SCM_ROLENGTH (s1); - s2len = i = SCM_ROLENGTH (s2); - if (len>i) i = len; - c1 = SCM_ROUCHARS (s1); - c2 = SCM_ROUCHARS (s2); - - for (i = 0;i<len;i++) { - c = (*c1++ - *c2++); - if (c>0) - return SCM_BOOL_F; - if (c<0) - return SCM_BOOL_T; - } - { - SCM answer; - answer = (s2len != len) ? SCM_BOOL_T : SCM_BOOL_F; - return answer; - } -} - -SCM_PROC1 (s_string_leq_p, "string<=?", scm_tc7_rpsubr, scm_string_leq_p); - -SCM -scm_string_leq_p (s1, s2) - SCM s1; - SCM s2; -{ - return SCM_BOOL_NOT (scm_string_less_p (s2, s1)); -} - -SCM_PROC1 (s_string_gr_p, "string>?", scm_tc7_rpsubr, scm_string_gr_p); - -SCM -scm_string_gr_p (s1, s2) - SCM s1; - SCM s2; -{ - return scm_string_less_p (s2, s1); -} - -SCM_PROC1 (s_string_geq_p, "string>=?", scm_tc7_rpsubr, scm_string_geq_p); - -SCM -scm_string_geq_p (s1, s2) - SCM s1; - SCM s2; -{ - return SCM_BOOL_NOT (scm_string_less_p (s1, s2)); -} - -SCM_PROC1 (s_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr, scm_string_ci_less_p); - -SCM -scm_string_ci_less_p (s1, s2) - SCM s1; - SCM s2; -{ - register scm_sizet i, len, s2len; - register unsigned char *c1, *c2; - register int c; - SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_ci_less_p); - SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_ci_less_p); - len = SCM_ROLENGTH (s1); - s2len = i = SCM_ROLENGTH (s2); - if (len>i) i=len; - c1 = SCM_ROUCHARS (s1); - c2 = SCM_ROUCHARS (s2); - for (i = 0;i<len;i++) { - c = (scm_upcase(*c1++) - scm_upcase(*c2++)); - if (c>0) return SCM_BOOL_F; - if (c<0) return SCM_BOOL_T; - } - return (s2len != len) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC1 (s_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr, scm_string_ci_leq_p); - -SCM -scm_string_ci_leq_p (s1, s2) - SCM s1; - SCM s2; -{ - return SCM_BOOL_NOT (scm_string_ci_less_p (s2, s1)); -} - -SCM_PROC1 (s_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, scm_string_ci_gr_p); - -SCM -scm_string_ci_gr_p (s1, s2) - SCM s1; - SCM s2; -{ - return scm_string_ci_less_p (s2, s1); -} - -SCM_PROC1 (s_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, scm_string_ci_geq_p); - -SCM -scm_string_ci_geq_p (s1, s2) - SCM s1; - SCM s2; -{ - return SCM_BOOL_NOT (scm_string_ci_less_p (s1, s2)); -} - - - -void -scm_init_strorder () -{ -#include "strorder.x" -} - diff --git a/libguile/strorder.h b/libguile/strorder.h deleted file mode 100644 index 2263a1c7f..000000000 --- a/libguile/strorder.h +++ /dev/null @@ -1,68 +0,0 @@ -/* classes: h_files */ - -#ifndef STRORDERH -#define STRORDERH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - - - -extern SCM scm_string_equal_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_ci_equal_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_less_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_leq_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_gr_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_geq_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_ci_less_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_ci_leq_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_ci_gr_p SCM_P ((SCM s1, SCM s2)); -extern SCM scm_string_ci_geq_p SCM_P ((SCM s1, SCM s2)); -extern void scm_init_strorder SCM_P ((void)); - -#endif /* STRORDERH */ diff --git a/libguile/strports.c b/libguile/strports.c deleted file mode 100644 index 3518c9cff..000000000 --- a/libguile/strports.c +++ /dev/null @@ -1,304 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "unif.h" -#include "eval.h" -#include "read.h" - -#include "strports.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - -/* {Ports - string ports} - * - */ - - -static int prinstpt SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinstpt (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_prinport (exp, port, "string"); - return !0; -} - - -static int stputc SCM_P ((int c, SCM p)); - -static int -stputc (c, p) - int c; - SCM p; -{ - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - SCM_DEFER_INTS; - if (ind >= SCM_LENGTH (SCM_CDR (p))) - scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + (ind >> 1))); - SCM_ALLOW_INTS; - SCM_CHARS (SCM_CDR (p))[ind] = c; - SCM_SETCAR (p, SCM_MAKINUM (ind + 1)); - return c; -} - - -static scm_sizet stwrite SCM_P ((char *str, scm_sizet siz, scm_sizet num, SCM p)); - -static scm_sizet -stwrite (str, siz, num, p) - char *str; - scm_sizet siz; - scm_sizet num; - SCM p; -{ - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - scm_sizet len = siz * num; - char *dst; - SCM_DEFER_INTS; - if (ind + len >= SCM_LENGTH (SCM_CDR (p))) - scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + len + ((ind + len) >> 1))); - SCM_ALLOW_INTS; - dst = &(SCM_CHARS (SCM_CDR (p))[ind]); - while (len--) - dst[len] = str[len]; - SCM_SETCAR (p, SCM_MAKINUM (ind + siz * num)); - return num; -} - - -static int stputs SCM_P ((char *s, SCM p)); - -static int -stputs (s, p) - char *s; - SCM p; -{ - stwrite (s, 1, strlen (s), p); - return 0; -} - - -static int stgetc SCM_P ((SCM p)); - -static int -stgetc (p) - SCM p; -{ - scm_sizet ind = SCM_INUM (SCM_CAR (p)); - if (ind >= SCM_ROLENGTH (SCM_CDR (p))) - return EOF; - SCM_SETCAR (p, SCM_MAKINUM (ind + 1)); - return SCM_ROUCHARS (SCM_CDR (p))[ind]; -} - - -SCM -scm_mkstrport (pos, str, modes, caller) - SCM pos; - SCM str; - long modes; - char * caller; -{ - SCM z; - SCM stream; - struct scm_port_table * pt; - - SCM_ASSERT(SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller); - SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, caller); - stream = scm_cons(pos, str); - SCM_NEWCELL (z); - SCM_DEFER_INTS; - pt = scm_add_to_port_table (z); - SCM_SETCAR (z, scm_tc16_strport | modes); - SCM_SETPTAB_ENTRY (z, pt); - SCM_SETSTREAM (z, stream); - SCM_ALLOW_INTS; - return z; -} - -SCM_PROC(s_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_call_with_output_string); - -SCM -scm_call_with_output_string (proc) - SCM proc; -{ - SCM p; - p = scm_mkstrport(SCM_INUM0, scm_make_string(SCM_MAKINUM(30), SCM_UNDEFINED), - SCM_OPN | SCM_WRTNG, - s_call_with_output_string); - scm_apply (proc, p, scm_listofnull); - { - SCM answer; - SCM_DEFER_INTS; - answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (p))), - SCM_INUM (SCM_CAR (SCM_STREAM (p))), - 0); - SCM_ALLOW_INTS; - return answer; - } -} - - - -/* Return a Scheme string obtained by printing a given object. - */ - - -SCM -scm_strprint_obj (obj) - SCM obj; -{ - SCM str; - SCM port; - - str = scm_makstr (64, 0); - port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj"); - scm_prin1 (obj, port, 1); - { - SCM answer; - SCM_DEFER_INTS; - answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (port))), - SCM_INUM (SCM_CAR (SCM_STREAM (port))), - 0); - SCM_ALLOW_INTS; - return answer; - } -} - - - - -SCM_PROC(s_call_with_input_string, "call-with-input-string", 2, 0, 0, scm_call_with_input_string); - -SCM -scm_call_with_input_string (str, proc) - SCM str; - SCM proc; -{ - SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, s_call_with_input_string); - return scm_apply (proc, p, scm_listofnull); -} - - - -/* Given a null-terminated string EXPR containing a Scheme expression - read it, and return it as an SCM value. */ -SCM -scm_read_0str (expr) - char *expr; -{ - SCM port = scm_mkstrport (SCM_MAKINUM (0), - scm_makfrom0str (expr), - SCM_OPN | SCM_RDNG, - "scm_eval_0str"); - SCM form; - - /* Read expressions from that port; ignore the values. */ - form = scm_read (port, SCM_BOOL_F, SCM_BOOL_F); - - scm_close_port (port); - return form; -} - -/* Given a null-terminated string EXPR containing Scheme program text, - evaluate it, and return the result of the last expression evaluated. */ -SCM -scm_eval_0str (expr) - char *expr; -{ - SCM port = scm_mkstrport (SCM_MAKINUM (0), - scm_makfrom0str (expr), - SCM_OPN | SCM_RDNG, - "scm_eval_0str"); - SCM form; - SCM ans = SCM_EOL; - - /* Read expressions from that port; ignore the values. */ - while ((form = scm_read (port, SCM_BOOL_F, SCM_BOOL_F)) != SCM_EOF_VAL) - ans = scm_eval_x (form); - - scm_close_port (port); - return ans; -} - - -static int noop0 SCM_P ((SCM stream)); - -static int -noop0 (stream) - SCM stream; -{ - return 0; -} - - -scm_ptobfuns scm_stptob = -{ - scm_markstream, - noop0, - prinstpt, - 0, - stputc, - stputs, - stwrite, - noop0, - stgetc, - 0 -}; - - - -void -scm_init_strports () -{ -#include "strports.x" -} - diff --git a/libguile/strports.h b/libguile/strports.h deleted file mode 100644 index fc0a1ed9f..000000000 --- a/libguile/strports.h +++ /dev/null @@ -1,61 +0,0 @@ -/* classes: h_files */ - -#ifndef STRPORTSH -#define STRPORTSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -extern scm_ptobfuns scm_stptob; - - - -extern SCM scm_mkstrport SCM_P ((SCM pos, SCM str, long modes, char * caller)); -extern SCM scm_call_with_output_string SCM_P ((SCM proc)); -extern SCM scm_strprint_obj SCM_P ((SCM obj)); -extern SCM scm_call_with_input_string SCM_P ((SCM str, SCM proc)); -extern SCM scm_read_0str SCM_P ((char *expr)); -extern SCM scm_eval_0str SCM_P ((char *expr)); -extern void scm_init_strports SCM_P ((void)); - -#endif /* STRPORTSH */ diff --git a/libguile/struct.c b/libguile/struct.c deleted file mode 100644 index 51f934e07..000000000 --- a/libguile/struct.c +++ /dev/null @@ -1,607 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" - -#include "struct.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - -static SCM required_vtable_fields = SCM_BOOL_F; -static int struct_num = 0; - - -SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout); - -SCM -scm_make_struct_layout (fields) - SCM fields; -{ - SCM new_sym; - SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields), - fields, SCM_ARG1, s_struct_make_layout); - - { - char * field_desc; - int len; - int x; - - len = SCM_ROLENGTH (fields); - field_desc = SCM_ROCHARS (fields); - SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout); - - for (x = 0; x < len; x += 2) - { - switch (field_desc[x]) - { - case 'u': - case 'p': -#if 0 - case 'i': - case 'd': -#endif - case 's': - break; - default: - SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout); - } - - switch (field_desc[x + 1]) - { - case 'w': - SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]), - "self fields not writable", s_struct_make_layout); - - case 'r': - case 'o': - break; - case 'R': - case 'W': - case 'O': - SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]), - "self fields not allowed in tail array", - s_struct_make_layout); - SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]), - "tail array field must be last field in layout", - s_struct_make_layout); - break; - default: - SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout); - } -#if 0 - if (field_desc[x] == 'd') - { - SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout); - x += 2; - goto recheck_ref; - } -#endif - } - new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F)); - } - return scm_return_first (new_sym, fields); -} - - - - - -static void init_struct SCM_P ((SCM handle, int tail_elts, SCM inits)); - -static void -init_struct (handle, tail_elts, inits) - SCM handle; - int tail_elts; - SCM inits; -{ - SCM layout; - SCM * data; - unsigned char * fields_desc; - unsigned char prot = 0; - int n_fields; - SCM * mem; - int tailp = 0; - - layout = SCM_STRUCT_LAYOUT (handle); - data = SCM_STRUCT_DATA (handle); - fields_desc = (unsigned char *) SCM_CHARS (layout) - 2; - n_fields = SCM_LENGTH (layout) / 2; - mem = SCM_STRUCT_DATA (handle); - while (n_fields) - { - if (!tailp) - { - fields_desc += 2; - prot = fields_desc[1]; - if (SCM_LAYOUT_TAILP (prot)) - { - tailp = 1; - prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o'; - *mem++ = tail_elts; - n_fields += tail_elts - 1; - if (n_fields == 0) - break; - } - } - - switch (*fields_desc) - { -#if 0 - case 'i': - if ((prot != 'r' && prot != 'w') || inits == SCM_EOL) - *mem = 0; - else - { - *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct"); - inits = SCM_CDR (inits); - } - break; -#endif - - case 'u': - if ((prot != 'r' && prot != 'w') || inits == SCM_EOL) - *mem = 0; - else - { - *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "init_struct"); - inits = SCM_CDR (inits); - } - break; - - case 'p': - if ((prot != 'r' && prot != 'w') || inits == SCM_EOL) - *mem = SCM_EOL; - else - { - *mem = SCM_CAR (inits); - inits = SCM_CDR (inits); - } - - break; - -#if 0 - case 'd': - if ((prot != 'r' && prot != 'w') || inits == SCM_EOL) - *((double *)mem) = 0.0; - else - { - *mem = scm_num2dbl (SCM_CAR (inits), "init_struct"); - inits = SCM_CDR (inits); - } - fields_desc += 2; - break; -#endif - - case 's': - *mem = handle; - break; - } - - n_fields--; - mem++; - } -} - - -SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p); - -SCM -scm_struct_p (x) - SCM x; -{ - return ((SCM_NIMP (x) && SCM_STRUCTP (x)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - -SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p); - -SCM -scm_struct_vtable_p (x) - SCM x; -{ - SCM layout; - SCM * mem; - - if (SCM_IMP (x)) - return SCM_BOOL_F; - - if (!SCM_STRUCTP (x)) - return SCM_BOOL_F; - - layout = SCM_STRUCT_LAYOUT (x); - - if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields)) - return SCM_BOOL_F; - - if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields), - SCM_LENGTH (required_vtable_fields))) - return SCM_BOOL_F; - - mem = SCM_STRUCT_DATA (x); - - if (mem[1] != 0) - return SCM_BOOL_F; - - if (SCM_IMP (mem[0])) - return SCM_BOOL_F; - - return (SCM_SYMBOLP (mem[0]) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -/* All struct data must be allocated at an address whose bottom three - bits are zero. This is because the tag for a struct lives in the - bottom three bits of the struct's car, and the upper bits point to - the data of its vtable, which is a struct itself. Thus, if the - address of that data doesn't end in three zeros, tagging it will - destroy the pointer. - - This function allocates a block of memory, and returns a pointer at - least scm_struct_n_extra_words words into the block. Furthermore, - it guarantees that that pointer's least three significant bits are - all zero. - - The argument n_words should be the number of words that should - appear after the returned address. (That is, it shouldn't include - scm_struct_n_extra_words.) - - This function initializes the following fields of the struct: - - scm_struct_i_ptr --- the actual stort of the block of memory; the - address you should pass to 'free' to dispose of the block. - This field allows us to both guarantee that the returned - address is divisible by eight, and allow the GC to free the - block. - - scm_struct_i_n_words --- the number of words allocated to the - block, including the extra fields. This is used by the GC. - - scm_struct_i_tag --- a unique tag assigned to this struct, - allocated according to struct_num. - - Ugh. */ - - -static SCM *alloc_struct SCM_P ((int n_words, char *who)); - -static SCM * -alloc_struct (n_words, who) - int n_words; - char *who; -{ - int size = sizeof (SCM) * (n_words + scm_struct_n_extra_words) + 7; - SCM *block = (SCM *) scm_must_malloc (size, who); - - /* Adjust the pointer to hide the extra words. */ - SCM *p = block + scm_struct_n_extra_words; - - /* Adjust it even further so it's aligned on an eight-byte boundary. */ - p = (SCM *) (((SCM) p + 7) & ~7); - - /* Initialize a few fields as described above. */ - p[scm_struct_i_ptr] = (SCM) block; - p[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words + n_words); - p[scm_struct_i_tag] = struct_num++; - - return p; -} - - -SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct); - -SCM -scm_make_struct (vtable, tail_array_size, init) - SCM vtable; - SCM tail_array_size; - SCM init; -{ - SCM layout; - int basic_size; - int tail_elts; - SCM * data; - SCM handle; - - SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)), - vtable, SCM_ARG1, s_make_struct); - SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, - s_make_struct); - - layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_layout]; - basic_size = SCM_LENGTH (layout) / 2; - tail_elts = SCM_INUM (tail_array_size); - SCM_NEWCELL (handle); - SCM_DEFER_INTS; - data = alloc_struct (basic_size + tail_elts, "make-struct"); - SCM_SETCDR (handle, data); - SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc); - init_struct (handle, tail_elts, init); - SCM_ALLOW_INTS; - return handle; -} - - - -SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable); - -SCM -scm_make_vtable_vtable (extra_fields, tail_array_size, init) - SCM extra_fields; - SCM tail_array_size; - SCM init; -{ - SCM fields; - SCM layout; - int basic_size; - int tail_elts; - SCM * data; - SCM handle; - - SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields), - extra_fields, SCM_ARG1, s_make_vtable_vtable); - SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2, - s_make_vtable_vtable); - - fields = scm_string_append (scm_listify (required_vtable_fields, - extra_fields, - SCM_UNDEFINED)); - layout = scm_make_struct_layout (fields); - basic_size = SCM_LENGTH (layout) / 2; - tail_elts = SCM_INUM (tail_array_size); - SCM_NEWCELL (handle); - SCM_DEFER_INTS; - data = alloc_struct (basic_size + tail_elts, "make-vtable-vtable"); - SCM_SETCDR (handle, data); - SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc); - SCM_STRUCT_LAYOUT (handle) = layout; - init_struct (handle, tail_elts, scm_cons (layout, init)); - SCM_ALLOW_INTS; - return handle; -} - - - - -SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref); - -SCM -scm_struct_ref (handle, pos) - SCM handle; - SCM pos; -{ - SCM answer = SCM_UNDEFINED; - SCM * data; - SCM layout; - int p; - int n_fields; - unsigned char * fields_desc; - unsigned char field_type; - - - SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle, - SCM_ARG1, s_struct_ref); - SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref); - - layout = SCM_STRUCT_LAYOUT (handle); - data = SCM_STRUCT_DATA (handle); - p = SCM_INUM (pos); - - fields_desc = (unsigned char *)SCM_CHARS (layout); - n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words; - - SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref); - - if (p * 2 < SCM_LENGTH (layout)) - { - unsigned char ref; - field_type = fields_desc[p * 2]; - ref = fields_desc[p * 2 + 1]; - if ((ref != 'r') && (ref != 'w')) - { - if ((ref == 'R') || (ref == 'W')) - field_type = 'u'; - else - SCM_ASSERT (0, pos, "ref denied", s_struct_ref); - } - } - else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O') - field_type = fields_desc[SCM_LENGTH (layout) - 2]; - else - { - SCM_ASSERT (0, pos, "ref denied", s_struct_ref); - abort (); - } - - switch (field_type) - { - case 'u': - answer = scm_ulong2num (data[p]); - break; - -#if 0 - case 'i': - answer = scm_long2num (data[p]); - break; - - case 'd': - answer = scm_makdbl (*((double *)&(data[p])), 0.0); - break; -#endif - - case 's': - case 'p': - answer = data[p]; - break; - - - default: - SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref); - break; - } - - return answer; -} - - -SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x); - -SCM -scm_struct_set_x (handle, pos, val) - SCM handle; - SCM pos; - SCM val; -{ - SCM * data; - SCM layout; - int p; - int n_fields; - unsigned char * fields_desc; - unsigned char field_type; - - - - SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle, - SCM_ARG1, s_struct_ref); - SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref); - - layout = SCM_STRUCT_LAYOUT (handle); - data = SCM_STRUCT_DATA (handle); - p = SCM_INUM (pos); - - fields_desc = (unsigned char *)SCM_CHARS (layout); - n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words; - - SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x); - - if (p * 2 < SCM_LENGTH (layout)) - { - unsigned char set_x; - field_type = fields_desc[p * 2]; - set_x = fields_desc [p * 2 + 1]; - if (set_x != 'w') - SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x); - } - else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W') - field_type = fields_desc[SCM_LENGTH (layout) - 2]; - else - { - SCM_ASSERT (0, pos, "set_x denied", s_struct_ref); - abort (); - } - - switch (field_type) - { - case 'u': - data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x); - break; - -#if 0 - case 'i': - data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x); - break; - - case 'd': - *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3); - break; -#endif - - case 'p': - data[p] = val; - break; - - case 's': - SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x); - break; - - default: - SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x); - break; - } - - return val; -} - - -SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable); - -SCM -scm_struct_vtable (handle) - SCM handle; -{ - SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle, - SCM_ARG1, s_struct_vtable); - return SCM_STRUCT_VTABLE (handle); -} - - -SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag); - -SCM -scm_struct_vtable_tag (handle) - SCM handle; -{ - SCM_ASSERT (SCM_NIMP (handle) && (SCM_BOOL_F != scm_struct_vtable_p (handle)), - handle, SCM_ARG1, s_struct_vtable_tag); - return scm_long2num (SCM_STRUCT_DATA (handle)[-1]); -} - - - - - -void -scm_init_struct () -{ - required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F)); - scm_permanent_object (required_vtable_fields); - scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset)); -#include "struct.x" -} - diff --git a/libguile/struct.h b/libguile/struct.h deleted file mode 100644 index e076a8aee..000000000 --- a/libguile/struct.h +++ /dev/null @@ -1,86 +0,0 @@ -/* classes: h_files */ - -#ifndef STRUCTH -#define STRUCTH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -/* Number of words with negative index */ -#define scm_struct_n_extra_words 3 - -/* These are how the initial words of a vtable are allocated. */ -#define scm_struct_i_ptr -3 /* start of block (see alloc_struct) */ -#define scm_struct_i_n_words -2 /* How many words allocated to this struct? */ -#define scm_struct_i_tag -1 /* A unique tag for this type.. */ -#define scm_struct_i_layout 0 /* A symbol describing the physical arrangement of this type. */ -#define scm_struct_i_vcell 1 /* An opaque word, managed by the garbage collector. */ -#define scm_struct_i_vtable 2 /* A pointer to the handle for this vtable. */ -#define scm_struct_i_vtable_offset 3 /* Where do user fields start? */ - - -#define SCM_STRUCTP(X) (SCM_TYP3(X) == scm_tc3_cons_gloc) -#define SCM_STRUCT_DATA(X) ((SCM*)(SCM_CDR(X))) -#define SCM_STRUCT_VTABLE_DATA(X) ((SCM *)(SCM_CAR(X) - 1)) -#define SCM_STRUCT_LAYOUT(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_layout]) -#define SCM_STRUCT_VTABLE(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_vtable]) -/* Efficiency is important in the following macro, since it's used in GC */ -#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */ - - - - -extern SCM scm_make_struct_layout SCM_P ((SCM fields)); -extern SCM scm_struct_p SCM_P ((SCM x)); -extern SCM scm_struct_vtable_p SCM_P ((SCM x)); -extern SCM scm_make_struct SCM_P ((SCM vtable, SCM tail_array_size, SCM init)); -extern SCM scm_make_vtable_vtable SCM_P ((SCM extra_fields, SCM tail_array_size, SCM init)); -extern SCM scm_struct_ref SCM_P ((SCM handle, SCM pos)); -extern SCM scm_struct_set_x SCM_P ((SCM handle, SCM pos, SCM val)); -extern SCM scm_struct_vtable SCM_P ((SCM handle)); -extern SCM scm_struct_vtable_tag SCM_P ((SCM handle)); -extern void scm_init_struct SCM_P ((void)); - -#endif /* STRUCTH */ diff --git a/libguile/symbols.c b/libguile/symbols.c deleted file mode 100644 index ec3fb9f93..000000000 --- a/libguile/symbols.c +++ /dev/null @@ -1,727 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "eval.h" -#include "variable.h" -#include "alist.h" -#include "mbstrings.h" - -#include "symbols.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - - -/* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets. - */ -#define NUM_HASH_BUCKETS 137 - - - - -/* {Symbols} - */ - - -unsigned long -scm_strhash (str, len, n) - unsigned char *str; - scm_sizet len; - unsigned long n; -{ - if (len > 5) - { - scm_sizet i = 5; - unsigned long h = 264 % n; - while (i--) - h = ((h << 8) + ((unsigned) (scm_downcase (str[h % len])))) % n; - return h; - } - else - { - scm_sizet i = len; - unsigned long h = 0; - while (i) - h = ((h << 8) + ((unsigned) (scm_downcase (str[--i])))) % n; - return h; - } -} - -int scm_symhash_dim = NUM_HASH_BUCKETS; - - -/* scm_sym2vcell - * looks up the symbol in the symhash table. - */ - -SCM -scm_sym2vcell (sym, thunk, definep) - SCM sym; - SCM thunk; - SCM definep; -{ - if (SCM_NIMP(thunk)) - { - SCM var = scm_apply (thunk, sym, scm_cons(definep, scm_listofnull)); - - if (var == SCM_BOOL_F) - return SCM_BOOL_F; - else - { - if (SCM_IMP(var) || !SCM_VARIABLEP (var)) - scm_wta (sym, "strangely interned symbol? ", ""); - return SCM_VARVCELL (var); - } - } - else - { - SCM lsym; - SCM * lsymp; - SCM z; - scm_sizet scm_hash = scm_strhash (SCM_UCHARS (sym), (scm_sizet) SCM_LENGTH (sym), - (unsigned long) scm_symhash_dim); - - SCM_DEFER_INTS; - for (lsym = SCM_VELTS (scm_symhash)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) - { - z = SCM_CAR (lsym); - if (SCM_CAR (z) == sym) - { - SCM_ALLOW_INTS; - return z; - } - } - - for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[scm_hash]); - SCM_NIMP (lsym); - lsym = *(lsymp = SCM_CDRLOC (lsym))) - { - z = SCM_CAR (lsym); - if (SCM_CAR (z) == sym) - { - if (definep) - { - /* Move handle from scm_weak_symhash to scm_symhash. */ - *lsymp = SCM_CDR (lsym); - SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[scm_hash]); - SCM_VELTS(scm_symhash)[scm_hash] = lsym; - } - SCM_ALLOW_INTS; - return z; - } - } - SCM_ALLOW_INTS; - return scm_wta (sym, "uninterned symbol? ", ""); - } -} - -/* scm_sym2ovcell - * looks up the symbol in an arbitrary obarray. - */ - -SCM -scm_sym2ovcell_soft (sym, obarray) - SCM sym; - SCM obarray; -{ - SCM lsym, z; - scm_sizet scm_hash; - - scm_hash = scm_strhash (SCM_UCHARS (sym), - (scm_sizet) SCM_LENGTH (sym), - SCM_LENGTH (obarray)); - SCM_REDEFER_INTS; - for (lsym = SCM_VELTS (obarray)[scm_hash]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - z = SCM_CAR (lsym); - if (SCM_CAR (z) == sym) - { - SCM_REALLOW_INTS; - return z; - } - } - SCM_REALLOW_INTS; - return SCM_BOOL_F; -} - - -SCM -scm_sym2ovcell (sym, obarray) - SCM sym; - SCM obarray; -{ - SCM answer; - answer = scm_sym2ovcell_soft (sym, obarray); - if (answer != SCM_BOOL_F) - return answer; - scm_wta (sym, "uninterned symbol? ", ""); - return SCM_UNSPECIFIED; /* not reached */ -} - -/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY. - - OBARRAY should be a vector of lists, indexed by the name's hash - value, modulo OBARRAY's length. Each list has the form - ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the - value associated with that symbol (in the current module? in the - system module?) - - To "intern" a symbol means: if OBARRAY already contains a symbol by - that name, return its (SYMBOL . VALUE) pair; otherwise, create a - new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the - appropriate list of the OBARRAY, and return the pair. - - If softness is non-zero, don't create a symbol if it isn't already - in OBARRAY; instead, just return #f. - - If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and - return (SYMBOL . SCM_UNDEFINED). - - If OBARRAY is scm_symhash, and that doesn't contain the symbol, - check scm_weak_symhash instead. */ - - -SCM -scm_intern_obarray_soft (name, len, obarray, softness) - char *name; - scm_sizet len; - SCM obarray; - int softness; -{ - SCM lsym; - SCM z; - register scm_sizet i; - register unsigned char *tmp; - scm_sizet scm_hash; - - SCM_REDEFER_INTS; - - i = len; - tmp = (unsigned char *) name; - - if (obarray == SCM_BOOL_F) - { - scm_hash = scm_strhash (tmp, i, 1019); - goto uninterned_symbol; - } - - scm_hash = scm_strhash (tmp, i, SCM_LENGTH(obarray)); - - /* softness == -1 used to mean that it was known that the symbol - wasn't already in the obarray. I don't think there are any - callers that use that case any more, but just in case... - -- JimB, Oct 1996 */ - if (softness == -1) - abort (); - - retry_new_obarray: - for (lsym = SCM_VELTS (obarray)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym)) - { - z = SCM_CAR (lsym); - z = SCM_CAR (z); - tmp = SCM_UCHARS (z); - if (SCM_LENGTH (z) != len) - goto trynext; - for (i = len; i--;) - if (((unsigned char *) name)[i] != tmp[i]) - goto trynext; - { - SCM a; - a = SCM_CAR (lsym); - SCM_REALLOW_INTS; - return a; - } - trynext:; - } - - if (obarray == scm_symhash) - { - obarray = scm_weak_symhash; - goto retry_new_obarray; - } - - uninterned_symbol: - if (softness) - { - SCM_REALLOW_INTS; - return SCM_BOOL_F; - } - - lsym = scm_makfromstr (name, len, SCM_SYMBOL_SLOTS); - - SCM_SETLENGTH (lsym, (long) len, scm_tc7_msymbol); - SCM_SYMBOL_MULTI_BYTE_STRINGP (lsym) = SCM_BOOL_F; - SCM_SYMBOL_HASH (lsym) = scm_hash; - SCM_SYMBOL_PROPS (lsym) = SCM_EOL; - if (obarray == SCM_BOOL_F) - { - SCM answer; - SCM_REALLOW_INTS; - SCM_NEWCELL (answer); - SCM_DEFER_INTS; - SCM_SETCAR (answer, lsym); - SCM_SETCDR (answer, SCM_UNDEFINED); - SCM_REALLOW_INTS; - return answer; - } - else - { - SCM a; - SCM b; - - SCM_NEWCELL (a); - SCM_NEWCELL (b); - SCM_SETCAR (a, lsym); - SCM_SETCDR (a, SCM_UNDEFINED); - SCM_SETCAR (b, a); - SCM_SETCDR (b, SCM_VELTS(obarray)[scm_hash]); - SCM_VELTS(obarray)[scm_hash] = b; - SCM_REALLOW_INTS; - return SCM_CAR (b); - } -} - - -SCM -scm_intern_obarray (name, len, obarray) - char *name; - scm_sizet len; - SCM obarray; -{ - return scm_intern_obarray_soft (name, len, obarray, 0); -} - - -SCM -scm_intern (name, len) - char *name; - scm_sizet len; -{ - return scm_intern_obarray (name, len, scm_symhash); -} - - -SCM -scm_intern0 (name) - char * name; -{ - return scm_intern (name, strlen (name)); -} - - -/* Intern the symbol named NAME in scm_symhash, and give it the value VAL. - NAME is null-terminated. */ -SCM -scm_sysintern (name, val) - char *name; - SCM val; -{ - SCM easy_answer; - SCM_DEFER_INTS; - easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1); - if (SCM_NIMP (easy_answer)) - { - SCM_SETCDR (easy_answer, val); - SCM_ALLOW_INTS; - return easy_answer; - } - else - { - SCM lsym; - scm_sizet len = strlen (name); - register unsigned char *tmp = (unsigned char *) name; - scm_sizet scm_hash = scm_strhash (tmp, len, (unsigned long) scm_symhash_dim); - SCM_NEWCELL (lsym); - SCM_SETLENGTH (lsym, (long) len, scm_tc7_ssymbol); - SCM_SETCHARS (lsym, name); - lsym = scm_cons (lsym, val); - SCM_VELTS (scm_symhash)[scm_hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[scm_hash]); - SCM_ALLOW_INTS; - return lsym; - } -} - - -SCM_PROC(s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p); - -SCM -scm_symbol_p(x) - SCM x; -{ - if SCM_IMP(x) return SCM_BOOL_F; - return SCM_SYMBOLP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_symbol_to_string, "symbol->string", 1, 0, 0, scm_symbol_to_string); - -SCM -scm_symbol_to_string(s) - SCM s; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_to_string); - return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0); -} - - -SCM_PROC(s_string_to_symbol, "string->symbol", 1, 0, 0, scm_string_to_symbol); - -SCM -scm_string_to_symbol(s) - SCM s; -{ - SCM vcell; - SCM answer; - - SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG1, s_string_to_symbol); - vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s)); - answer = SCM_CAR (vcell); - if (SCM_TYP7 (answer) == scm_tc7_msymbol) - { - if (SCM_REGULAR_STRINGP (s)) - SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F; - else - SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T; - } - return answer; -} - - -SCM_PROC(s_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, scm_string_to_obarray_symbol); - -SCM -scm_string_to_obarray_symbol(o, s, softp) - SCM o; - SCM s; - SCM softp; -{ - SCM vcell; - SCM answer; - int softness; - - SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG2, - s_string_to_obarray_symbol); - SCM_ASSERT((o == SCM_BOOL_F) - || (o == SCM_BOOL_T) - || (SCM_NIMP(o) && SCM_VECTORP(o)), - o, - SCM_ARG1, - s_string_to_obarray_symbol); - - softness = ((softp != SCM_UNDEFINED) && (softp != SCM_BOOL_F)); - /* iron out some screwy calling conventions */ - if (o == SCM_BOOL_F) - o = scm_symhash; - else if (o == SCM_BOOL_T) - o = SCM_BOOL_F; - - vcell = scm_intern_obarray_soft (SCM_ROCHARS(s), - (scm_sizet)SCM_ROLENGTH(s), - o, - softness); - if (vcell == SCM_BOOL_F) - return vcell; - answer = SCM_CAR (vcell); - if (SCM_TYP7 (s) == scm_tc7_msymbol) - { - if (SCM_REGULAR_STRINGP (s)) - SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F; - else - SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T; - } - return answer; -} - -SCM_PROC(s_intern_symbol, "intern-symbol", 2, 0, 0, scm_intern_symbol); - -SCM -scm_intern_symbol(o, s) - SCM o; - SCM s; -{ - scm_sizet hval; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_intern_symbol); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_intern_symbol); - hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o)); - /* If the symbol is already interned, simply return. */ - SCM_REDEFER_INTS; - { - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval]; - SCM_NIMP (lsym); - lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_CAR (sym) == s) - { - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; - } - } - SCM_VELTS (o)[hval] = - scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]); - } - SCM_REALLOW_INTS; - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_unintern_symbol, "unintern-symbol", 2, 0, 0, scm_unintern_symbol); - -SCM -scm_unintern_symbol(o, s) - SCM o; - SCM s; -{ - scm_sizet hval; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_unintern_symbol); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_unintern_symbol); - hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o)); - SCM_DEFER_INTS; - { - SCM lsym_follow; - SCM lsym; - SCM sym; - for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F; - SCM_NIMP (lsym); - lsym_follow = lsym, lsym = SCM_CDR (lsym)) - { - sym = SCM_CAR (lsym); - if (SCM_CAR (sym) == s) - { - /* Found the symbol to unintern. */ - if (lsym_follow == SCM_BOOL_F) - SCM_VELTS(o)[hval] = lsym; - else - SCM_SETCDR (lsym_follow, SCM_CDR(lsym)); - SCM_ALLOW_INTS; - return SCM_BOOL_T; - } - } - } - SCM_ALLOW_INTS; - return SCM_BOOL_F; -} - -SCM_PROC(s_symbol_binding, "symbol-binding", 2, 0, 0, scm_symbol_binding); - -SCM -scm_symbol_binding (o, s) - SCM o; - SCM s; -{ - SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_binding); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_binding); - vcell = scm_sym2ovcell (s, o); - return SCM_CDR(vcell); -} - - -SCM_PROC(s_symbol_interned_p, "symbol-interned?", 2, 0, 0, scm_symbol_interned_p); - -SCM -scm_symbol_interned_p (o, s) - SCM o; - SCM s; -{ - SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_interned_p); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_interned_p); - vcell = scm_sym2ovcell_soft (s, o); - if (SCM_IMP(vcell) && (o == scm_symhash)) - vcell = scm_sym2ovcell_soft (s, scm_weak_symhash); - return (SCM_NIMP(vcell) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC(s_symbol_bound_p, "symbol-bound?", 2, 0, 0, scm_symbol_bound_p); - -SCM -scm_symbol_bound_p (o, s) - SCM o; - SCM s; -{ - SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_bound_p); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_bound_p); - vcell = scm_sym2ovcell_soft (s, o); - return (( SCM_NIMP(vcell) - && (SCM_CDR(vcell) != SCM_UNDEFINED)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC(s_symbol_set_x, "symbol-set!", 3, 0, 0, scm_symbol_set_x); - -SCM -scm_symbol_set_x (o, s, v) - SCM o; - SCM s; - SCM v; -{ - SCM vcell; - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_set_x); - if (o == SCM_BOOL_F) - o = scm_symhash; - SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_set_x); - vcell = scm_sym2ovcell (s, o); - SCM_SETCDR (vcell, v); - return SCM_UNSPECIFIED; -} - -static void -msymbolize (s) - SCM s; -{ - SCM string; - string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS); - SCM_SETCHARS (s, SCM_CHARS (string)); - SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol); - SCM_SYMBOL_MULTI_BYTE_STRINGP (s) = SCM_BOOL_F; - SCM_SETCDR (string, SCM_EOL); - SCM_SETCAR (string, SCM_EOL); -} - - -SCM_PROC(s_symbol_fref, "symbol-fref", 1, 0, 0, scm_symbol_fref); - -SCM -scm_symbol_fref (s) - SCM s; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fref); - SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - SCM_ALLOW_INTS; - return SCM_SYMBOL_FUNC (s); -} - - -SCM_PROC(s_symbol_pref, "symbol-pref", 1, 0, 0, scm_symbol_pref); - -SCM -scm_symbol_pref (s) - SCM s; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pref); - SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - SCM_ALLOW_INTS; - return SCM_SYMBOL_PROPS (s); -} - - -SCM_PROC(s_symbol_fset_x, "symbol-fset!", 2, 0, 0, scm_symbol_fset_x); - -SCM -scm_symbol_fset_x (s, val) - SCM s; - SCM val; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fset_x); - SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - SCM_ALLOW_INTS; - SCM_SYMBOL_FUNC (s) = val; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_symbol_pset_x, "symbol-pset!", 2, 0, 0, scm_symbol_pset_x); - -SCM -scm_symbol_pset_x (s, val) - SCM s; - SCM val; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pset_x); - SCM_DEFER_INTS; - if (SCM_TYP7(s) == scm_tc7_ssymbol) - msymbolize (s); - SCM_SYMBOL_PROPS (s) = val; - SCM_ALLOW_INTS; - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_symbol_hash, "symbol-hash", 1, 0, 0, scm_symbol_hash); - -SCM -scm_symbol_hash (s) - SCM s; -{ - SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_hash); - return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s)); -} - - - -void -scm_init_symbols () -{ -#include "symbols.x" -} - diff --git a/libguile/symbols.h b/libguile/symbols.h deleted file mode 100644 index f8a75d5f3..000000000 --- a/libguile/symbols.h +++ /dev/null @@ -1,132 +0,0 @@ -/* classes: h_files */ - -#ifndef SYMBOLSH -#define SYMBOLSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -extern int scm_symhash_dim; - -/* SCM_LENGTH(SYM) is the length of SYM's name in characters, and - SCM_CHARS(SYM) is the address of the first character of SYM's name. - - Beyond that, there are two kinds of symbols: ssymbols and msymbols, - distinguished by the 'S' bit in the type. - - Ssymbols are just uniquified strings. They have a length, chars, - and that's it. They use the scm_tc7_ssymbol tag (S bit clear). - - Msymbols are symbols with extra slots. These slots hold a property - list and a function value (for Emacs Lisp compatibility), a hash - code, and a flag to indicate whether their name contains multibyte - characters. They use the scm_tc7_msymbol tag. - - We'd like SCM_CHARS to work on msymbols just as it does on - ssymbols, so we'll have it point to the symbol's name as usual, and - store a pointer to the slots just before the name in memory. Thus, - you have to do some casting and pointer arithmetic to find the - slots; see the SCM_SLOTS macro. - - In practice, the slots always live just before the pointer to them. - So why not ditch the pointer, and use negative indices to refer to - the slots? That's a good question; ask the author. I think it was - the cognac. */ - -#define SCM_SYMBOLP(x) (SCM_TYP7S(x)==scm_tc7_ssymbol) -#define SCM_LENGTH(x) (((unsigned long)SCM_CAR(x))>>8) -#define SCM_LENGTH_MAX (0xffffffL) -#define SCM_SETLENGTH(x, v, t) SCM_SETCAR((x), ((v)<<8)+(t)) -#define SCM_SETCHARS SCM_SETCDR -#define SCM_CHARS(x) ((char *)(SCM_CDR(x))) -#define SCM_UCHARS(x) ((unsigned char *)(SCM_CDR(x))) -#define SCM_SLOTS(x) ((SCM *) (* ((SCM *)SCM_CHARS(x) - 1))) -#define SCM_SYMBOL_SLOTS 5 -#define SCM_SYMBOL_FUNC(X) (SCM_SLOTS(X)[0]) -#define SCM_SYMBOL_PROPS(X) (SCM_SLOTS(X)[1]) -#define SCM_SYMBOL_HASH(X) (*(unsigned long*)(&SCM_SLOTS(X)[2])) -#define SCM_SYMBOL_MULTI_BYTE_STRINGP(X) (*(unsigned long*)(&SCM_SLOTS(X)[3])) - -#define SCM_ROSTRINGP(x) ((SCM_TYP7SD(x)==scm_tc7_string) || (SCM_TYP7S(x) == scm_tc7_ssymbol)) -#define SCM_ROCHARS(x) ((SCM_TYP7(x) == scm_tc7_substring) \ - ? SCM_INUM (SCM_CADR (x)) + SCM_CHARS (SCM_CDDR (x)) \ - : SCM_CHARS (x)) -#define SCM_ROUCHARS(x) ((SCM_TYP7(x) == scm_tc7_substring) \ - ? SCM_INUM (SCM_CADR (x)) + SCM_UCHARS (SCM_CDDR (x)) \ - : SCM_UCHARS (x)) -#define SCM_ROLENGTH(x) SCM_LENGTH (x) -#define SCM_SUBSTRP(x) ((SCM_TYP7S(x) == scm_tc7_substring)) -#define SCM_SUBSTR_STR(x) (SCM_CDDR (x)) -#define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x)) - - - - -extern unsigned long scm_strhash SCM_P ((unsigned char *str, scm_sizet len, unsigned long n)); -extern SCM scm_sym2vcell SCM_P ((SCM sym, SCM thunk, SCM definep)); -extern SCM scm_sym2ovcell_soft SCM_P ((SCM sym, SCM obarray)); -extern SCM scm_sym2ovcell SCM_P ((SCM sym, SCM obarray)); -extern SCM scm_intern_obarray_soft SCM_P ((char *name, scm_sizet len, SCM obarray, int softness)); -extern SCM scm_intern_obarray SCM_P ((char *name, scm_sizet len, SCM obarray)); -extern SCM scm_intern SCM_P ((char *name, scm_sizet len)); -extern SCM scm_intern0 SCM_P ((char * name)); -extern SCM scm_sysintern SCM_P ((char *name, SCM val)); -extern SCM scm_symbol_p SCM_P ((SCM x)); -extern SCM scm_symbol_to_string SCM_P ((SCM s)); -extern SCM scm_string_to_symbol SCM_P ((SCM s)); -extern SCM scm_string_to_obarray_symbol SCM_P ((SCM o, SCM s, SCM softp)); -extern SCM scm_intern_symbol SCM_P ((SCM o, SCM s)); -extern SCM scm_unintern_symbol SCM_P ((SCM o, SCM s)); -extern SCM scm_symbol_binding SCM_P ((SCM o, SCM s)); -extern SCM scm_symbol_interned_p SCM_P ((SCM o, SCM s)); -extern SCM scm_symbol_bound_p SCM_P ((SCM o, SCM s)); -extern SCM scm_symbol_set_x SCM_P ((SCM o, SCM s, SCM v)); -extern SCM scm_symbol_fref SCM_P ((SCM s)); -extern SCM scm_symbol_pref SCM_P ((SCM s)); -extern SCM scm_symbol_fset_x SCM_P ((SCM s, SCM val)); -extern SCM scm_symbol_pset_x SCM_P ((SCM s, SCM val)); -extern SCM scm_symbol_hash SCM_P ((SCM s)); -extern void scm_init_symbols SCM_P ((void)); - -#endif /* SYMBOLSH */ diff --git a/libguile/tag.c b/libguile/tag.c deleted file mode 100644 index 09f0effe5..000000000 --- a/libguile/tag.c +++ /dev/null @@ -1,215 +0,0 @@ -/* Copyright (C) 1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "struct.h" - -#include "tag.h" - - -SCM_CONST_LONG (scm_utag_immediate_integer, "utag_immediate_integer", 0); -SCM_CONST_LONG (scm_utag_immediate_char, "utag_immediate_char", 1); -SCM_CONST_LONG (scm_utag_pair, "utag_pair", 2); -SCM_CONST_LONG (scm_utag_closure, "utag_closure", 3); -SCM_CONST_LONG (scm_utag_symbol, "utag_symbol", 4); -SCM_CONST_LONG (scm_utag_vector, "utag_vector", 5); -SCM_CONST_LONG (scm_utag_wvect, "utag_wvect", 6); -SCM_CONST_LONG (scm_utag_bvect, "utag_bvect", 7); -SCM_CONST_LONG (scm_utag_byvect, "utag_byvect", 8); -SCM_CONST_LONG (scm_utag_svect, "utag_svect", 9); -SCM_CONST_LONG (scm_utag_ivect, "utag_ivect", 10); -SCM_CONST_LONG (scm_utag_uvect, "utag_uvect", 11); -SCM_CONST_LONG (scm_utag_fvect, "utag_fvect", 12); -SCM_CONST_LONG (scm_utag_dvect, "utag_dvect", 13); -SCM_CONST_LONG (scm_utag_cvect, "utag_cvect", 14); -SCM_CONST_LONG (scm_utag_string, "utag_string", 15); -SCM_CONST_LONG (scm_utag_mb_string, "utag_mb_string", 16); -SCM_CONST_LONG (scm_utag_substring, "utag_substring", 17); -SCM_CONST_LONG (scm_utag_mb_substring, "utag_mb_substring", 18); -SCM_CONST_LONG (scm_utag_asubr, "utag_asubr", 19); -SCM_CONST_LONG (scm_utag_subr_0, "utag_subr_0", 20); -SCM_CONST_LONG (scm_utag_subr_1, "utag_subr_1", 21); -SCM_CONST_LONG (scm_utag_cxr, "utag_cxr", 22); -SCM_CONST_LONG (scm_utag_subr_3, "utag_subr_3", 23); -SCM_CONST_LONG (scm_utag_subr_2, "utag_subr_2", 24); -SCM_CONST_LONG (scm_utag_rpsubr, "utag_rpsubr", 25); -SCM_CONST_LONG (scm_utag_subr_1o, "utag_subr_1o", 26); -SCM_CONST_LONG (scm_utag_subr_2o, "utag_subr_2o", 27); -SCM_CONST_LONG (scm_utag_lsubr_2, "utag_lsubr_2", 28); -SCM_CONST_LONG (scm_utag_lsubr, "utag_lsubr", 29); -SCM_CONST_LONG (scm_utag_smob_base, "utag_smob_base", 252); -SCM_CONST_LONG (scm_utag_port_base, "utag_port_base", 253); -SCM_CONST_LONG (scm_utag_flag_base, "utag_flag_base", 254); -SCM_CONST_LONG (scm_utag_struct_base, "utag_struct_base", 255); - - -SCM_PROC (s_tag, "tag", 1, 0, 0, scm_tag); - -SCM -scm_tag (x) - SCM x; -{ - switch (SCM_ITAG3 (x)) - { - case scm_tc3_int_1: - case scm_tc3_int_2: - return SCM_CDR (scm_utag_immediate_integer) ; - - case scm_tc3_imm24: - if (SCM_ICHRP (x)) - return SCM_CDR (scm_utag_immediate_char) ; - else - { - int tag; - tag = SCM_MAKINUM ((x >> 8) & 0xff); - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_flag_base) ) | (tag << 8)); - } - - case scm_tc3_cons: - switch (SCM_TYP7 (x)) - { - case scm_tcs_cons_nimcar: - return SCM_CDR (scm_utag_pair) ; - case scm_tcs_closures: - return SCM_CDR (scm_utag_closure) ; - case scm_tcs_symbols: - return SCM_CDR (scm_utag_symbol) ; - case scm_tc7_vector: - return SCM_CDR (scm_utag_vector) ; - case scm_tc7_wvect: - return SCM_CDR (scm_utag_wvect) ; - case scm_tc7_bvect: - return SCM_CDR (scm_utag_bvect) ; - case scm_tc7_byvect: - return SCM_CDR (scm_utag_byvect) ; - case scm_tc7_svect: - return SCM_CDR (scm_utag_svect) ; - case scm_tc7_ivect: - return SCM_CDR (scm_utag_ivect) ; - case scm_tc7_uvect: - return SCM_CDR (scm_utag_uvect) ; - case scm_tc7_fvect: - return SCM_CDR (scm_utag_fvect) ; - case scm_tc7_dvect: - return SCM_CDR (scm_utag_dvect) ; - case scm_tc7_cvect: - return SCM_CDR (scm_utag_cvect) ; - case scm_tc7_string: - return SCM_CDR (scm_utag_string) ; - case scm_tc7_mb_string: - return SCM_CDR (scm_utag_mb_string) ; - case scm_tc7_substring: - return SCM_CDR (scm_utag_substring) ; - case scm_tc7_mb_substring: - return SCM_CDR (scm_utag_mb_substring) ; - case scm_tc7_asubr: - return SCM_CDR (scm_utag_asubr) ; - case scm_tc7_subr_0: - return SCM_CDR (scm_utag_subr_0) ; - case scm_tc7_subr_1: - return SCM_CDR (scm_utag_subr_1) ; - case scm_tc7_cxr: - return SCM_CDR (scm_utag_cxr) ; - case scm_tc7_subr_3: - return SCM_CDR (scm_utag_subr_3) ; - case scm_tc7_subr_2: - return SCM_CDR (scm_utag_subr_2) ; - case scm_tc7_rpsubr: - return SCM_CDR (scm_utag_rpsubr) ; - case scm_tc7_subr_1o: - return SCM_CDR (scm_utag_subr_1o) ; - case scm_tc7_subr_2o: - return SCM_CDR (scm_utag_subr_2o) ; - case scm_tc7_lsubr_2: - return SCM_CDR (scm_utag_lsubr_2) ; - case scm_tc7_lsubr: - return SCM_CDR (scm_utag_lsubr) ; - - case scm_tc7_port: - { - int tag; - tag = (SCM_TYP16 (x) >> 8) & 0xff; - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_port_base)) | (tag << 8)); - } - case scm_tc7_smob: - { - int tag; - tag = (SCM_TYP16 (x) >> 8) & 0xff; - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_smob_base)) | (tag << 8)); - } - case scm_tcs_cons_gloc: - /* must be a struct */ - { - int tag; - tag = SCM_STRUCT_VTABLE_DATA (x)[scm_struct_i_tag]; - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_struct_base)) | (tag << 8)); - } - return SCM_CDR (scm_utag_struct_base) ; - - default: - if (SCM_CONSP (x)) - return SCM_CDR (scm_utag_pair); - else - return SCM_MAKINUM (-1); - } - - case scm_tc3_cons_gloc: - case scm_tc3_tc7_1: - case scm_tc3_tc7_2: - case scm_tc3_closure: - /* Never reached */ - break; - } - return SCM_MAKINUM (-1); -} - - - - - -void -scm_init_tag () -{ -#include "tag.x" -} - diff --git a/libguile/tag.h b/libguile/tag.h deleted file mode 100644 index 9c4952bdf..000000000 --- a/libguile/tag.h +++ /dev/null @@ -1,58 +0,0 @@ -/* classes: h_files */ - -#ifndef TAGH -#define TAGH -/* Copyright (C) 1995 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - - - - -extern SCM scm_tag SCM_P ((SCM x)); -extern void scm_init_tag SCM_P ((void)); - -#endif /* TAGH */ diff --git a/libguile/tags.h b/libguile/tags.h deleted file mode 100644 index 1b21ba8c9..000000000 --- a/libguile/tags.h +++ /dev/null @@ -1,539 +0,0 @@ -/* classes: h_files */ - -#ifndef TAGSH -#define TAGSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -/** This file defines the format of SCM values and cons pairs. - ** It is here that tag bits are assigned for various purposes. - **/ - - - -/* In the beginning was the Word: - */ -typedef long SCM; - - - -/* Cray machines have pointers that are incremented once for each word, - * rather than each byte, the 3 most significant bits encode the byte - * within the word. The following macros deal with this by storing the - * native Cray pointers like the ones that looks like scm expects. This - * is done for any pointers that might appear in the car of a scm_cell, pointers - * to scm_vector elts, functions, &c are not munged. - */ -#ifdef _UNICOS -# define SCM2PTR(x) ((int)(x) >> 3) -# define PTR2SCM(x) (((SCM)(x)) << 3) -# define SCM_POINTERS_MUNGED -#else -# define SCM2PTR(x) (x) -# define PTR2SCM(x) ((SCM)(x)) -#endif /* def _UNICOS */ - - -/* SCM variables can contain: - * - * Non-objects -- meaning that the tag-related macros don't apply to them - * in the usual way. - * - * Immediates -- meaning that the variable contains an entire Scheme object. - * - * Non-immediates -- meaning that the variable holds a (possibly - * tagged) pointer into the cons pair heap. - * - * Non-objects are distinguished from other values by careful coding - * only (i.e., programmers must keep track of any SCM variables they - * create that don't contain ordinary scheme values). - * - * All immediates and non-immediates must have a 0 in bit 0. Only - * non-object values can have a 1 in bit 0. In some cases, bit 0 of a - * word in the heap is used for the GC tag so during garbage - * collection, that bit might be 1 even in an immediate or - * non-immediate value. In other cases, bit 0 of a word in the heap - * is used to tag a pointer to a GLOC (VM global variable address) or - * the header of a struct. But whenever an SCM variable holds a - * normal Scheme value, bit 0 is 0. - * - * Immediates and non-immediates are distinguished by bits two and four. - * Immediate values must have a 1 in at least one of those bits. Does - * this (or any other detail of tagging) seem arbitrary? Try changing it! - * (Not always impossible but it is fair to say that many details of tags - * are mutually dependent). */ - -#define SCM_IMP(x) (6 & (int)(x)) -#define SCM_NIMP(x) (!SCM_IMP(x)) - -/* Here is a summary of tagging in SCM values as they might occur in - * SCM variables or in the heap. - * - * low bits meaning - * - * - * 0 Most objects except... - * 1 ...glocs and structs (this tag valid only in a SCM_CAR or - * in the header of a struct's data). - * - * 00 heap addresses and many immediates (not integers) - * 01 glocs/structs, some tc7_ codes - * 10 immediate integers - * 11 various tc7_ codes including, tc16_ codes. - * - * - * 000 heap address - * 001 glocs/structs - * 010 integer - * 011 closure - * 100 immediates - * 101 tc7_ - * 110 integer - * 111 tc7_ - * - * - * 100 --- IMMEDIATES - * - * Looking at the seven final bits of an immediate: - * - * 0000-100 short instruction - * 0001-100 short instruction - * 0010-100 short instruction - * 0011-100 short instruction - * 0100-100 short instruction - * 0101-100 short instruction - * 0110-100 various immediates and long instructions - * 0111-100 short instruction - * 1000-100 short instruction - * 1001-100 short instruction - * 1010-100 short instruction - * 1011-100 short instruction - * 1100-100 short instruction - * 1101-100 short instruction - * 1110-100 immediate characters - * 1111-100 ilocs - * - * Some of the 0110100 immediates are long instructions (they dispatch - * in two steps compared to one step for a short instruction). - * The two steps are, (1) dispatch on 7 bits to the long instruction - * handler, (2) dispatch on 7 additional bits. - * - * One way to think of it is that there are 128 short instructions, - * with the 13 immediates above being some of the most interesting. - * - * Also noteworthy are the groups of 16 7-bit instructions implied by - * some of the 3-bit tags. For example, closure references consist - * of an 8-bit aligned address tagged with 011. There are 16 identical 7-bit - * instructions, all ending 011, which are invoked by evaluating closures. - * - * In other words, if you hand the evaluator a closure, the evaluator - * treats the closure as a graph of virtual machine instructions. - * A closure is a pair with a pointer to the body of the procedure - * in the CDR and a pointer to the environment of the closure in the CAR. - * The environment pointer is tagged 011 which implies that the least - * significant 7 bits of the environment pointer also happen to be - * a virtual machine instruction we could call "SELF" (for self-evaluating - * object). - * - * A less trivial example are the 16 instructions ending 000. If those - * bits tag the CAR of a pair, then evidently the pair is an ordinary - * cons pair and should be evaluated as a procedure application. The sixteen, - * 7-bit 000 instructions are all "NORMAL-APPLY" (Things get trickier. - * For example, if the CAR of a procedure application is a symbol, the NORMAL-APPLY - * instruction will, as a side effect, overwrite that CAR with a new instruction - * that contains a cached address for the variable named by the symbol.) - * - * Here is a summary of tags in the CAR of a non-immediate: - * - * HEAP CELL: G=gc_mark; 1 during mark, 0 other times. - * - * cons ..........SCM car..............0 ...........SCM cdr.............G - * gloc ..........SCM vcell..........001 ...........SCM cdr.............G - * struct ..........void * type........001 ...........void * data.........G - * closure ..........SCM code...........011 ...........SCM env.............G - * tc7 .........long length....GxxxD1S1 ..........void *data............ - * - * - * - * 101 & 111 --- tc7_ types - * - * tc7_tags are 7 bit tags ending in 1x1. These tags - * occur only in the CAR of heap cells, and have the - * handy property that all bits of the CAR above the - * bottom eight can be used to store a length, thus - * saving a word in the body itself. Thus, we use them - * for strings, symbols, and vectors (among other - * things). - * - * SCM_LENGTH returns the bits in "length" (see the diagram). - * SCM_CHARS returns the data cast to "char *" - * SCM_CDR returns the data cast to "SCM" - * TYP7(X) returns bits 0...6 of SCM_CAR (X) - * - * For the interpretation of SCM_LENGTH and SCM_CHARS - * that applies to a particular type, see the header file - * for that type. - * - * Sometimes we choose the bottom seven bits carefully, - * so that the 4- and 1-valued bits (called the D and S - * bits) can be masked off to reveal a common type. - * - * TYP7S(X) returns TYP7, but masking out the option bit S. - * TYP7D(X) returns TYP7, but masking out the option bit D. - * TYP7SD(X) masks out both option bits. - * - * For example, all strings have 001 in the 'xxx' bits in - * the diagram above, the D bit says whether it's a - * substring, and the S bit says whether it's a multibyte - * character string. - * - * for example: - * D S - * scm_tc7_string = G0010101 - * scm_tc7_mb_string = G0010111 - * scm_tc7_substring = G0011101 - * scm_tc7_mb_substring = G0011111 - * - * TYP7DS turns all string tags into tc7_string; thus, - * testing TYP7DS against tc7_string is a quick way to - * test for any kind of string. - * - * TYP7S turns tc7_mb_string into tc7_string and - * tc7_mb_substring into tc7_substring. - * - * TYP7D turns tc7_mb_substring into tc7_mb_string and - * tc7_substring into tc7_string. - * - * Some TC7 types are subdivided into 256 subtypes giving - * rise to the macros: - * - * TYP16 - * TYP16S - * GCTYP16 - * - * TYP16S functions similarly wrt to TYP16 as TYP7S to TYP7, - * but a different option bit is used (bit 2 for TYP7S, - * bit 8 for TYP16S). - * */ - - - - -/* {Non-immediate values.} - * - * If X is non-immediate, it is necessary to look at SCM_CAR (X) to - * figure out Xs type. X may be a cons pair, in which case the - * value SCM_CAR (x) will be either an immediate or non-immediate value. - * X may be something other than a cons pair, in which case the value SCM_CAR (x) - * will be a non-object value. - * - * All immediates and non-immediates have a 0 in bit 0. We additionally preserve - * the invariant that all non-object values stored in the SCM_CAR of a non-immediate - * object have a 1 in bit 1: - */ - -#define SCM_NCONSP(x) (1 & (int)SCM_CAR(x)) -#define SCM_CONSP(x) (!SCM_NCONSP(x)) - - -/* ECONSP is historical and, in fact, slightly buggy. - * There are two places to fix where structures and glocs can be confused. - * !!! - */ -#define SCM_ECONSP(x) (SCM_CONSP(x) || (1==SCM_TYP3(x))) -#define SCM_NECONSP(x) (SCM_NCONSP(x) && (1 != SCM_TYP3(x))) - - - -#define SCM_CELLP(x) (!SCM_NCELLP(x)) -#define SCM_NCELLP(x) ((sizeof(scm_cell)-1) & (int)(x)) - -/* See numbers.h for macros relating to immediate integers. - */ - -#define SCM_ITAG3(x) (7 & (int)x) -#define SCM_TYP3(x) (7 & (int)SCM_CAR(x)) -#define scm_tc3_cons 0 -#define scm_tc3_cons_gloc 1 -#define scm_tc3_int_1 2 -#define scm_tc3_closure 3 -#define scm_tc3_imm24 4 -#define scm_tc3_tc7_1 5 -#define scm_tc3_int_2 6 -#define scm_tc3_tc7_2 7 - - -/* - * Do not change the three bit tags. - */ - - -#define SCM_TYP7(x) (0x7f & (int)SCM_CAR(x)) -#define SCM_TYP7S(x) (0x7d & (int)SCM_CAR(x)) -#define SCM_TYP7SD(x) (0x75 & (int)SCM_CAR(x)) -#define SCM_TYP7D(x) (0x77 & (int)SCM_CAR(x)) - - -#define SCM_TYP16(x) (0xffff & (int)SCM_CAR(x)) -#define SCM_TYP16S(x) (0xfeff & (int)SCM_CAR(x)) -#define SCM_GCTYP16(x) (0xff7f & (int)SCM_CAR(x)) - - - -/* Testing and Changing GC Marks in Various Standard Positions - */ -#define SCM_GCMARKP(x) (1 & (int)SCM_CDR(x)) -#define SCM_GC8MARKP(x) (0x80 & (int)SCM_CAR(x)) -#define SCM_SETGCMARK(x) SCM_SETOR_CDR (x,1) -#define SCM_CLRGCMARK(x) SCM_SETAND_CDR (x, ~1L) -#define SCM_SETGC8MARK(x) SCM_SETOR_CAR (x, 0x80) -#define SCM_CLRGC8MARK(x) SCM_SETAND_CAR (x, ~0x80L) - - - - -/* couple */ -#define scm_tc7_ssymbol 5 -#define scm_tc7_msymbol 7 - -/* couple */ -#define scm_tc7_vector 13 -#define scm_tc7_wvect 15 - -/* a quad, two couples, two trists */ -#define scm_tc7_string 21 -#define scm_tc7_mb_string 23 -#define scm_tc7_substring 29 -#define scm_tc7_mb_substring 31 - -/* Many of the following should be turned - * into structs or smobs. We need back some - * of these 7 bit tags! - */ -#define scm_tc7_uvect 37 -#define scm_tc7_lvector 39 -#define scm_tc7_fvect 45 -#define scm_tc7_dvect 47 -#define scm_tc7_cvect 53 -#define scm_tc7_svect 55 -#define scm_tc7_contin 61 -#define scm_tc7_cclo 63 -#define scm_tc7_rpsubr 69 -#define scm_tc7_bvect 71 -#define scm_tc7_byvect 77 -#define scm_tc7_ivect 79 -#define scm_tc7_subr_0 85 -#define scm_tc7_subr_1 87 -#define scm_tc7_cxr 93 -#define scm_tc7_subr_3 95 -#define scm_tc7_subr_2 101 -#define scm_tc7_asubr 103 -#define scm_tc7_subr_1o 109 -#define scm_tc7_subr_2o 111 -#define scm_tc7_lsubr_2 117 -#define scm_tc7_lsubr 119 - - -/* There are 256 port subtypes. Here are the first four. - * These must agree with the init function in ports.c - */ -#define scm_tc7_port 125 - -/* fports and pipes form an intended TYP16S equivelancy - * group (similar to a tc7 "couple". - */ -#define scm_tc16_fport (scm_tc7_port + 0*256L) -#define scm_tc16_pipe (scm_tc7_port + 1*256L) - -#define scm_tc16_strport (scm_tc7_port + 2*256L) -#define scm_tc16_sfport (scm_tc7_port + 3*256L) - - -/* There are 256 smob subtypes. Here are the first four. - */ - -#define scm_tc7_smob 127 /* DO NOT CHANGE [**] */ - -/* [**] If you change scm_tc7_smob, you must also change - * the places it is hard coded in this file and possibly others. - */ - - -/* scm_tc_free_cell is also the 0th smob type. - */ -#define scm_tc_free_cell 127 - -/* The 1st smob type: - */ -#define scm_tc16_flo 0x017f -#define scm_tc_flo 0x017fL - -/* Some option bits begeinning at bit 16 of scm_tc16_flo: - */ -#define SCM_REAL_PART (1L<<16) -#define SCM_IMAG_PART (2L<<16) -#define scm_tc_dblr (scm_tc16_flo|SCM_REAL_PART) -#define scm_tc_dblc (scm_tc16_flo|SCM_REAL_PART|SCM_IMAG_PART) - - -/* Smob types 2 and 3: - */ -#define scm_tc16_bigpos 0x027f -#define scm_tc16_bigneg 0x037f - - - -/* {Immediate Values} - */ - -enum scm_tags -{ - scm_tc8_char = 0xf4, - scm_tc8_iloc = 0xfc, -}; - -#define SCM_ITAG8(X) ((int)(X) & 0xff) -#define SCM_MAKE_ITAG8(X, TAG) (((X)<<8) + TAG) -#define SCM_ITAG8_DATA(X) ((X)>>8) - - - -/* Immediate Symbols, Special Symbols, Flags (various constants). - */ - -/* SCM_ISYMP tests for ISPCSYM and ISYM */ -#define SCM_ISYMP(n) ((0x187 & (int)(n))==4) - -/* SCM_IFLAGP tests for ISPCSYM, ISYM and IFLAG */ -#define SCM_IFLAGP(n) ((0x87 & (int)(n))==4) -#define SCM_ISYMNUM(n) ((int)((n)>>9)) -#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM(n)]) -#define SCM_MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L) -#define SCM_MAKISYM(n) (((n)<<9)+0x74L) -#define SCM_MAKIFLAG(n) (((n)<<9)+0x174L) - -/* This table must agree with the declarations - * in repl.c: {Names of immediate symbols}. - * - * These are used only in eval but their values - * have to be allocated here. - * - */ - -#define SCM_IM_AND SCM_MAKSPCSYM(0) -#define SCM_IM_BEGIN SCM_MAKSPCSYM(1) -#define SCM_IM_CASE SCM_MAKSPCSYM(2) -#define SCM_IM_COND SCM_MAKSPCSYM(3) -#define SCM_IM_DO SCM_MAKSPCSYM(4) -#define SCM_IM_IF SCM_MAKSPCSYM(5) -#define SCM_IM_LAMBDA SCM_MAKSPCSYM(6) -#define SCM_IM_LET SCM_MAKSPCSYM(7) -#define SCM_IM_LETSTAR SCM_MAKSPCSYM(8) -#define SCM_IM_LETREC SCM_MAKSPCSYM(9) -#define SCM_IM_OR SCM_MAKSPCSYM(10) -#define SCM_IM_QUOTE SCM_MAKSPCSYM(11) -#define SCM_IM_SET SCM_MAKSPCSYM(12) -#define SCM_IM_DEFINE SCM_MAKSPCSYM(13) -#define SCM_IM_APPLY SCM_MAKISYM(14) -#define SCM_IM_CONT SCM_MAKISYM(15) -#define SCM_BOOL_F SCM_MAKIFLAG(16) -#define SCM_BOOL_T SCM_MAKIFLAG(17) -#define SCM_UNDEFINED SCM_MAKIFLAG(18) -#define SCM_EOF_VAL SCM_MAKIFLAG(19) -#define SCM_EOL SCM_MAKIFLAG(20) -#define SCM_UNSPECIFIED SCM_MAKIFLAG(21) - - -#define SCM_UNBNDP(x) (SCM_UNDEFINED==(x)) - - - -/* Dispatching aids: - */ - - -/* For cons pairs with immediate values in the CAR - */ - -#define scm_tcs_cons_imcar 2:case 4:case 6:case 10:\ - case 12:case 14:case 18:case 20:\ - case 22:case 26:case 28:case 30:\ - case 34:case 36:case 38:case 42:\ - case 44:case 46:case 50:case 52:\ - case 54:case 58:case 60:case 62:\ - case 66:case 68:case 70:case 74:\ - case 76:case 78:case 82:case 84:\ - case 86:case 90:case 92:case 94:\ - case 98:case 100:case 102:case 106:\ - case 108:case 110:case 114:case 116:\ - case 118:case 122:case 124:case 126 - -/* For cons pairs with non-immediate values in the SCM_CAR - */ -#define scm_tcs_cons_nimcar 0:case 8:case 16:case 24:\ - case 32:case 40:case 48:case 56:\ - case 64:case 72:case 80:case 88:\ - case 96:case 104:case 112:case 120 - -/* A CONS_GLOC occurs in code. It's CAR is a pointer to the - * CDR of a variable. The low order bits of the CAR are 001. - * The CDR of the gloc is the code continuation. - */ -#define scm_tcs_cons_gloc 1:case 9:case 17:case 25:\ - case 33:case 41:case 49:case 57:\ - case 65:case 73:case 81:case 89:\ - case 97:case 105:case 113:case 121 - -#define scm_tcs_closures 3:case 11:case 19:case 27:\ - case 35:case 43:case 51:case 59:\ - case 67:case 75:case 83:case 91:\ - case 99:case 107:case 115:case 123 - -#define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1:case scm_tc7_cxr:\ - case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\ - case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr - -#define scm_tcs_symbols scm_tc7_ssymbol:case scm_tc7_msymbol - -#define scm_tcs_bignums scm_tc16_bigpos:case scm_tc16_bigneg - -#endif /* TAGSH */ diff --git a/libguile/throw.c b/libguile/throw.c deleted file mode 100644 index 7e67df4da..000000000 --- a/libguile/throw.c +++ /dev/null @@ -1,496 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "smob.h" -#include "alist.h" -#include "eval.h" -#include "dynwind.h" -#include "backtrace.h" -#ifdef DEBUG_EXTENSIONS -#include "debug.h" -#endif -#include "continuations.h" -#include "stackchk.h" - -#include "throw.h" - - -/* {Catch and Throw} - */ -static int scm_tc16_jmpbuffer; - -#define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer) -#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L)) -#define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L))) -#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L))) - -#ifndef DEBUG_EXTENSIONS -#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) ) -#define SETJBJMPBUF SCM_SETCDR -#else -#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) ) -#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) ) -#define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X)) -#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X) - -static scm_sizet freejb SCM_P ((SCM jbsmob)); - -static scm_sizet -freejb (jbsmob) - SCM jbsmob; -{ - scm_must_free ((char *) SCM_CDR (jbsmob)); - return sizeof (scm_cell); -} -#endif - -static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); -static int -printjb (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port); - scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port); - scm_intprint((SCM) JBJMPBUF(exp), 16, port); - scm_gen_putc ('>', port); - return 1 ; -} - -static scm_smobfuns jbsmob = { - scm_mark0, -#ifdef DEBUG_EXTENSIONS - freejb, -#else - scm_free0, -#endif - printjb, - 0 -}; - -static SCM make_jmpbuf SCM_P ((void)); -static SCM -make_jmpbuf () -{ - SCM answer; - SCM_NEWCELL (answer); - SCM_REDEFER_INTS; - { -#ifdef DEBUG_EXTENSIONS - char *mem = scm_must_malloc (sizeof (scm_cell), "jb"); - SCM_SETCDR (answer, (SCM) mem); -#endif - SCM_SETCAR (answer, scm_tc16_jmpbuffer); - SETJBJMPBUF(answer, (jmp_buf *)0); - DEACTIVATEJB(answer); - } - SCM_REALLOW_INTS; - return answer; -} - -struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ -{ - jmp_buf buf; /* must be first */ - SCM throw_tag; - SCM retval; -}; - - -/* scm_internal_catch is the guts of catch. It handles all the - mechanics of setting up a catch target, invoking the catch body, - and perhaps invoking the handler if the body does a throw. - - The function is designed to be usable from C code, but is general - enough to implement all the semantics Guile Scheme expects from - throw. - - TAG is the catch tag. Typically, this is a symbol, but this - function doesn't actually care about that. - - BODY is a pointer to a C function which runs the body of the catch; - this is the code you can throw from. We call it like this: - BODY (DATA, JMPBUF) - where: - DATA is just the DATA argument we received; we pass it through - to BODY as its first argument. The caller can make DATA point - to anything useful that BODY might need. - JMPBUF is the Scheme jmpbuf object corresponding to this catch, - which we have just created and initialized. - - HANDLER is a pointer to a C function to deal with a throw to TAG, - should one occur. We call it like this: - HANDLER (DATA, TAG, THROW_ARGS) - where - DATA is the DATA argument we recevied, as for BODY above. - TAG is the tag that the user threw to; usually this is TAG, but - it could be something else if TAG was #t (i.e., a catch-all), - or the user threw to a jmpbuf. - THROW_ARGS is the list of arguments the user passed to the THROW - function. - - DATA is just a pointer we pass through to BODY and (if we call it) - HANDLER. We don't actually use it otherwise ourselves. The idea - is that, if our caller wants to communicate something to BODY and - HANDLER, it can pass a pointer to it as DATA, which BODY and - HANDLER can then use. Think of it as a way to make BODY and - HANDLER closures, not just functions; DATA points to the enclosed - variables. */ - -SCM -scm_internal_catch (tag, body, handler, data) - SCM tag; - scm_catch_body_t body; - scm_catch_handler_t handler; - void *data; -{ - struct jmp_buf_and_retval jbr; - SCM jmpbuf; - SCM answer; - - jmpbuf = make_jmpbuf (); - answer = SCM_EOL; - scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds); - SETJBJMPBUF(jmpbuf, &jbr.buf); -#ifdef DEBUG_EXTENSIONS - SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame); -#endif - if (setjmp (jbr.buf)) - { - SCM throw_tag; - SCM throw_args; - -#ifdef STACK_CHECKING - scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; -#endif - SCM_REDEFER_INTS; - DEACTIVATEJB (jmpbuf); - scm_dynwinds = SCM_CDR (scm_dynwinds); - SCM_REALLOW_INTS; - throw_args = jbr.retval; - throw_tag = jbr.throw_tag; - jbr.throw_tag = SCM_EOL; - jbr.retval = SCM_EOL; - answer = handler (data, throw_tag, throw_args); - } - else - { - ACTIVATEJB (jmpbuf); - answer = body (data, jmpbuf); - SCM_REDEFER_INTS; - DEACTIVATEJB (jmpbuf); - scm_dynwinds = SCM_CDR (scm_dynwinds); - SCM_REALLOW_INTS; - } - return answer; -} - - -/* scm_catch passes a pointer to one of these structures through to - its body and handler routines, to tell them what to do. */ -struct catch_body_data -{ - /* The tag being caught. We only use it to figure out what - arguments to pass to the body procedure; see catch_body for - details. */ - SCM tag; - - /* The Scheme procedure object constituting the catch body. - catch_body invokes this. */ - SCM body_proc; - - /* The Scheme procedure object we invoke to handle throws. */ - SCM handler_proc; -}; - - -/* This function runs the catch body. DATA contains the Scheme - procedure to invoke. If the tag being caught is #f, then we pass - JMPBUF to the body procedure; otherwise, it gets no arguments. */ -static SCM catch_body SCM_P ((void *, SCM)); - -static SCM -catch_body (data, jmpbuf) - void *data; - SCM jmpbuf; -{ - struct catch_body_data *c = (struct catch_body_data *) data; - - if (c->tag == SCM_BOOL_F) - return scm_apply (c->body_proc, scm_cons (jmpbuf, SCM_EOL), SCM_EOL); - else - return scm_apply (c->body_proc, SCM_EOL, SCM_EOL); -} - - -/* If the user does a throw to this catch, this function runs the - handler. DATA says which Scheme procedure object to invoke. */ -static SCM catch_handler SCM_P ((void *, SCM, SCM)); - -static SCM -catch_handler (data, tag, throw_args) - void *data; - SCM tag; - SCM throw_args; -{ - struct catch_body_data *c = (struct catch_body_data *) data; - - return scm_apply (c->handler_proc, scm_cons (tag, throw_args), SCM_EOL); -} - - -SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch); -SCM -scm_catch (tag, thunk, handler) - SCM tag; - SCM thunk; - SCM handler; -{ - struct catch_body_data c; - - SCM_ASSERT ((tag == SCM_BOOL_F) - || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) - || (tag == SCM_BOOL_T), - tag, SCM_ARG1, s_catch); - - c.tag = tag; - c.body_proc = thunk; - c.handler_proc = handler; - - /* scm_internal_catch takes care of all the mechanics of setting up - a catch tag; we tell it to call catch_body to run the body, and - catch_handler to deal with any throws to this catch. Both those - functions receive the pointer to c, which tells them the details - of how to behave. */ - return scm_internal_catch (tag, catch_body, catch_handler, (void *) &c); -} - -SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch); -SCM -scm_lazy_catch (tag, thunk, handler) - SCM tag; - SCM thunk; - SCM handler; -{ - SCM answer; - SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag)) - || (tag == SCM_BOOL_T), - tag, SCM_ARG1, s_lazy_catch); - SCM_REDEFER_INTS; - scm_dynwinds = scm_acons (tag, handler, scm_dynwinds); - SCM_REALLOW_INTS; - answer = scm_apply (thunk, SCM_EOL, SCM_EOL); - SCM_REDEFER_INTS; - scm_dynwinds = SCM_CDR (scm_dynwinds); - SCM_REALLOW_INTS; - return answer; -} - -/* The user has thrown to an uncaught key --- print a message and die. - 1) If the user wants something different, they can use (catch #t - ...) to do what they like. - 2) Outside the context of a read-eval-print loop, there isn't - anything else good to do; libguile should not assume the existence - of a read-eval-print loop. - 3) Given that we shouldn't do anything complex, it's much more - robust to do it in C code. */ -static SCM uncaught_throw SCM_P ((SCM key, SCM args)); -static SCM -uncaught_throw (key, args) - SCM key; - SCM args; -{ - SCM p = scm_def_errp; - - if (scm_ilength (args) >= 3) - { - SCM message = SCM_CADR (args); - SCM parts = SCM_CADDR (args); - - scm_gen_puts (scm_regular_string, "guile: ", p); - scm_display_error_message (message, parts, p); - } - else - { - scm_gen_puts (scm_regular_string, "guile: uncaught throw to ", p); - scm_prin1 (key, p, 0); - scm_gen_puts (scm_regular_string, ": ", p); - scm_prin1 (args, p, 1); - scm_gen_putc ('\n', p); - } - - exit (2); -} - - -static char s_throw[]; -SCM -scm_ithrow (key, args, noreturn) - SCM key; - SCM args; - int noreturn; -{ - SCM jmpbuf; - SCM wind_goal; - - if (SCM_NIMP (key) && SCM_JMPBUFP (key)) - { - jmpbuf = key; - if (noreturn) - { - SCM_ASSERT (JBACTIVE (jmpbuf), jmpbuf, - "throw to dynamically inactive catch", - s_throw); - } - else if (!JBACTIVE (jmpbuf)) - return SCM_UNSPECIFIED; - } - else - { - SCM dynpair = SCM_UNDEFINED; - SCM winds; - - if (noreturn) - { - SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, - s_throw); - } - else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key))) - return SCM_UNSPECIFIED; - - /* Search the wind list for an appropriate catch. - "Waiter, please bring us the wind list." */ - for (winds = scm_dynwinds; SCM_NIMP (winds); winds = SCM_CDR (winds)) - { - if (! SCM_CONSP (winds)) - abort (); - - dynpair = SCM_CAR (winds); - if (SCM_NIMP (dynpair) && SCM_CONSP (dynpair)) - { - SCM this_key = SCM_CAR (dynpair); - - if (this_key == SCM_BOOL_T || this_key == key) - break; - } - } - - /* If we didn't find anything, print a message and exit Guile. */ - if (winds == SCM_EOL) - uncaught_throw (key, args); - - if (SCM_IMP (winds) || SCM_NCONSP (winds)) - abort (); - - if (dynpair != SCM_BOOL_F) - jmpbuf = SCM_CDR (dynpair); - else - { - if (!noreturn) - return SCM_UNSPECIFIED; - else - { - scm_exitval = scm_cons (key, args); - scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds)); -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_DFRAME (scm_rootcont); -#endif - longjmp (SCM_JMPBUF (scm_rootcont), 1); - } - } - } - for (wind_goal = scm_dynwinds; - SCM_CDAR (wind_goal) != jmpbuf; - wind_goal = SCM_CDR (wind_goal)) - ; - if (!SCM_JMPBUFP (jmpbuf)) - { - SCM oldwinds = scm_dynwinds; - SCM handle, answer; - scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal)); - SCM_REDEFER_INTS; - handle = scm_dynwinds; - scm_dynwinds = SCM_CDR (scm_dynwinds); - SCM_REALLOW_INTS; - answer = scm_apply (jmpbuf, scm_cons (key, args), SCM_EOL); - SCM_REDEFER_INTS; - SCM_SETCDR (handle, scm_dynwinds); - scm_dynwinds = handle; - SCM_REALLOW_INTS; - scm_dowinds (oldwinds, scm_ilength (scm_dynwinds) - scm_ilength (oldwinds)); - return answer; - } - else - { - struct jmp_buf_and_retval * jbr; - scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal)); - jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf); - jbr->throw_tag = key; - jbr->retval = args; - } -#ifdef DEBUG_EXTENSIONS - scm_last_debug_frame = SCM_JBDFRAME (jmpbuf); -#endif - longjmp (*JBJMPBUF (jmpbuf), 1); -} - - -SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw); -SCM -scm_throw (key, args) - SCM key; - SCM args; -{ - /* May return if handled by lazy catch. */ - return scm_ithrow (key, args, 1); -} - - -void -scm_init_throw () -{ - scm_tc16_jmpbuffer = scm_newsmob (&jbsmob); -#include "throw.x" -} diff --git a/libguile/throw.h b/libguile/throw.h deleted file mode 100644 index 83d8e946d..000000000 --- a/libguile/throw.h +++ /dev/null @@ -1,65 +0,0 @@ -/* classes: h_files */ - -#ifndef THROWH -#define THROWH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -typedef SCM (*scm_catch_body_t) SCM_P ((void *data, SCM jmpbuf)); -typedef SCM (*scm_catch_handler_t) SCM_P ((void *data, - SCM tag, SCM throw_args)); - -extern SCM scm_internal_catch SCM_P ((SCM tag, - scm_catch_body_t body, - scm_catch_handler_t handler, - void *data)); - -extern SCM scm_catch SCM_P ((SCM tag, SCM thunk, SCM handler)); -extern SCM scm_lazy_catch SCM_P ((SCM tag, SCM thunk, SCM handler)); -extern SCM scm_ithrow SCM_P ((SCM key, SCM args, int noreturn)); -extern SCM scm_throw SCM_P ((SCM key, SCM args)); -extern void scm_init_throw SCM_P ((void)); -#endif /* THROWH */ diff --git a/libguile/unif.c b/libguile/unif.c deleted file mode 100644 index 922101722..000000000 --- a/libguile/unif.c +++ /dev/null @@ -1,2538 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "chars.h" -#include "eval.h" -#include "genio.h" -#include "smob.h" -#include "sequences.h" -#include "strop.h" -#include "feature.h" - -#include "unif.h" -#include "ramap.h" - - -/* The set of uniform scm_vector types is: - * Vector of: Called: - * unsigned char string - * char byvect - * boolean bvect - * signed int ivect - * unsigned int uvect - * float fvect - * double dvect - * complex double cvect - * short svect - * long_long llvect - */ - -long scm_tc16_array; - -/* - * This complicates things too much if allowed on any array. - * C code can safely call it on arrays known to be used in a single - * threaded manner. - * - * SCM_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x); - */ -static char s_vector_set_length_x[] = "vector-set-length!"; - - -SCM -scm_vector_set_length_x (vect, len) - SCM vect; - SCM len; -{ - long l; - scm_sizet siz; - scm_sizet sz; - - l = SCM_INUM (len); - SCM_ASRTGO (SCM_NIMP (vect), badarg1); - switch (SCM_TYP7 (vect)) - { - default: - badarg1: scm_wta (vect, (char *) SCM_ARG1, s_vector_set_length_x); - case scm_tc7_string: - case scm_tc7_mb_string: - SCM_ASRTGO (vect != scm_nullstr, badarg1); - sz = sizeof (char); - l++; - break; - case scm_tc7_vector: - SCM_ASRTGO (vect != scm_nullvect, badarg1); - sz = sizeof (SCM); - break; -#ifdef ARRAYS - case scm_tc7_bvect: - l = (l + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - case scm_tc7_uvect: - case scm_tc7_ivect: - sz = sizeof (long); - break; - case scm_tc7_byvect: - sz = sizeof (char); - break; - - case scm_tc7_svect: - sz = sizeof (short); - break; -#ifdef LONGLONGS - case scm_tc7_llvect: - sz = sizeof (long_long); - break; -#endif - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - sz = sizeof (float); - break; -#endif - case scm_tc7_dvect: - sz = sizeof (double); - break; - case scm_tc7_cvect: - sz = 2 * sizeof (double); - break; -#endif -#endif - } - SCM_ASSERT (SCM_INUMP (len), len, SCM_ARG2, s_vector_set_length_x); - if (!l) - l = 1L; - siz = l * sz; - if (siz != l * sz) - scm_wta (SCM_MAKINUM (l * sz), (char *) SCM_NALLOC, s_vector_set_length_x); - SCM_REDEFER_INTS; - SCM_SETCHARS (vect, - ((char *) - scm_must_realloc (SCM_CHARS (vect), - (long) SCM_LENGTH (vect) * sz, - (long) siz, - s_vector_set_length_x))); - if (SCM_VECTORP (vect)) - { - sz = SCM_LENGTH (vect); - while (l > sz) - SCM_VELTS (vect)[--l] = SCM_UNSPECIFIED; - } - else if (SCM_STRINGP (vect)) - SCM_CHARS (vect)[l - 1] = 0; - SCM_SETLENGTH (vect, SCM_INUM (len), SCM_TYP7 (vect)); - SCM_REALLOW_INTS; - return vect; -} - - -#ifdef ARRAYS - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - - -SCM -scm_makflo (x) - float x; -{ - SCM z; - if (x == 0.0) - return scm_flo0; - SCM_NEWCELL (z); - SCM_DEFER_INTS; - SCM_SETCAR (z, scm_tc_flo); - SCM_FLO (z) = x; - SCM_ALLOW_INTS; - return z; -} -#endif -#endif - - -SCM -scm_make_uve (k, prot) - long k; - SCM prot; -{ - SCM v; - long i, type; - if (SCM_BOOL_T == prot) - { - i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - type = scm_tc7_bvect; - } - else if (SCM_ICHRP (prot) && (prot == SCM_MAKICHR ('\0'))) - { - i = sizeof (char) * k; - type = scm_tc7_byvect; - } - else if (SCM_ICHRP (prot)) - { - i = sizeof (char) * k; - type = scm_tc7_string; - } - else if (SCM_INUMP (prot)) - { - i = sizeof (long) * k; - if (SCM_INUM (prot) > 0) - type = scm_tc7_uvect; - else - type = scm_tc7_ivect; - } - else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot))) - { - char s; - - s = SCM_CHARS (prot)[0]; - if (s == 's') - { - i = sizeof (short) * k; - type = scm_tc7_svect; - } -#ifdef LONGLONGS - else if (s == 'l') - { - i = sizeof (long_long) * k; - type = scm_tc7_llvect; - } -#endif - else - { - return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED, SCM_UNDEFINED); - } - } - else -#ifdef SCM_FLOATS - if (SCM_IMP (prot) || !SCM_INEXP (prot)) -#endif - /* Huge non-unif vectors are NOT supported. */ - return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED, SCM_UNDEFINED); /* no special scm_vector */ -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - else if (SCM_SINGP (prot)) - - { - i = sizeof (float) * k; - type = scm_tc7_fvect; - } -#endif - else if (SCM_CPLXP (prot)) - { - i = 2 * sizeof (double) * k; - type = scm_tc7_cvect; - } - else - { - i = sizeof (double) * k; - type = scm_tc7_dvect; - } -#endif - - SCM_NEWCELL (v); - SCM_DEFER_INTS; - { - char *m; - m = scm_must_malloc ((i ? i : 1L), "vector"); - SCM_SETCHARS (v, (char *) m); - } - SCM_SETLENGTH (v, (k < SCM_LENGTH_MAX ? k : SCM_LENGTH_MAX), type); - SCM_ALLOW_INTS; - return v; -} - -SCM_PROC(s_uniform_vector_length, "uniform-vector-length", 1, 0, 0, scm_uniform_vector_length); - -SCM -scm_uniform_vector_length (v) - SCM v; -{ - SCM_ASRTGO (SCM_NIMP (v), badarg1); - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_length); - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_vector: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - return SCM_MAKINUM (SCM_LENGTH (v)); - } -} - -SCM_PROC(s_array_p, "array?", 1, 1, 0, scm_array_p); - -SCM -scm_array_p (v, prot) - SCM v; - SCM prot; -{ - int nprot; - int enclosed; - nprot = SCM_UNBNDP (prot); - enclosed = 0; - if (SCM_IMP (v)) - return SCM_BOOL_F; -loop: - switch (SCM_TYP7 (v)) - { - case scm_tc7_smob: - if (!SCM_ARRAYP (v)) - return SCM_BOOL_F; - if (nprot) - return SCM_BOOL_T; - if (enclosed++) - return SCM_BOOL_F; - v = SCM_ARRAY_V (v); - goto loop; - case scm_tc7_bvect: - return nprot || SCM_BOOL_T==prot ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_string: - return nprot || (SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'))) ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_byvect: - return nprot || (prot == SCM_MAKICHR('\0')) ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_uvect: - return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)>0) ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_ivect: - return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)<=0) ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_svect: - return ( nprot - || (SCM_NIMP (prot) - && SCM_SYMBOLP (prot) - && (1 == SCM_LENGTH (prot)) - && ('s' == SCM_CHARS (prot)[0]))); -#ifdef LONGLONGS - case scm_tc7_llvect: - return ( nprot - || (SCM_NIMP (prot) - && SCM_SYMBOLP (prot) - && (1 == SCM_LENGTH (prot)) - && ('s' == SCM_CHARS (prot)[0]))); -#endif -# ifdef SCM_FLOATS -# ifdef SCM_SINGLES - case scm_tc7_fvect: - return nprot || (SCM_NIMP(prot) && SCM_SINGP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; -# endif - case scm_tc7_dvect: - return nprot || (SCM_NIMP(prot) && SCM_REALP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; - case scm_tc7_cvect: - return nprot || (SCM_NIMP(prot) && SCM_CPLXP(prot)) ? SCM_BOOL_T : SCM_BOOL_F; -# endif - case scm_tc7_vector: - return nprot || SCM_NULLP(prot) ? SCM_BOOL_T : SCM_BOOL_F; - default:; - } - return SCM_BOOL_F; -} - - -SCM_PROC(s_array_rank, "array-rank", 1, 0, 0, scm_array_rank); - -SCM -scm_array_rank (ra) - SCM ra; -{ - if (SCM_IMP (ra)) - return SCM_INUM0; - switch (SCM_TYP7 (ra)) - { - default: - return SCM_INUM0; - case scm_tc7_string: - case scm_tc7_vector: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_cvect: - case scm_tc7_dvect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - case scm_tc7_svect: - return SCM_MAKINUM (1L); - case scm_tc7_smob: - if (SCM_ARRAYP (ra)) - return SCM_MAKINUM (SCM_ARRAY_NDIM (ra)); - return SCM_INUM0; - } -} - - -SCM_PROC(s_array_dimensions, "array-dimensions", 1, 0, 0, scm_array_dimensions); - -SCM -scm_array_dimensions (ra) - SCM ra; -{ - SCM res = SCM_EOL; - scm_sizet k; - scm_array_dim *s; - if (SCM_IMP (ra)) - return SCM_BOOL_F; - switch (SCM_TYP7 (ra)) - { - default: - return SCM_BOOL_F; - case scm_tc7_string: - case scm_tc7_vector: - case scm_tc7_bvect: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_cvect: - case scm_tc7_dvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra)), SCM_EOL); - case scm_tc7_smob: - if (!SCM_ARRAYP (ra)) - return SCM_BOOL_F; - k = SCM_ARRAY_NDIM (ra); - s = SCM_ARRAY_DIMS (ra); - while (k--) - res = scm_cons (s[k].lbnd ? scm_cons2 (SCM_MAKINUM (s[k].lbnd), SCM_MAKINUM (s[k].ubnd), SCM_EOL) : - SCM_MAKINUM (1 + (s[k].ubnd)) - , res); - return res; - } -} - - -static char s_bad_ind[] = "Bad scm_array index"; - - -long -scm_aind (ra, args, what) - SCM ra; - SCM args; - char *what; -{ - SCM ind; - register long j; - register scm_sizet pos = SCM_ARRAY_BASE (ra); - register scm_sizet k = SCM_ARRAY_NDIM (ra); - scm_array_dim *s = SCM_ARRAY_DIMS (ra); - if (SCM_INUMP (args)) - { - SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL); - return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); - } - while (k && SCM_NIMP (args)) - { - ind = SCM_CAR (args); - args = SCM_CDR (args); - SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, what); - j = SCM_INUM (ind); - SCM_ASSERT (j >= (s->lbnd) && j <= (s->ubnd), ind, SCM_OUTOFRANGE, what); - pos += (j - s->lbnd) * (s->inc); - k--; - s++; - } - SCM_ASSERT (0 == k && SCM_NULLP (args), scm_makfrom0str (what), SCM_WNA, - NULL); - return pos; -} - - - -SCM -scm_make_ra (ndim) - int ndim; -{ - SCM ra; - SCM_NEWCELL (ra); - SCM_DEFER_INTS; - SCM_SETCDR (ra, scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)), - "array")); - SCM_SETCAR (ra, ((long) ndim << 17) + scm_tc16_array); - SCM_ARRAY_V (ra) = scm_nullvect; - SCM_ALLOW_INTS; - return ra; -} - -static char s_bad_spec[] = "Bad scm_array dimension"; -/* Increments will still need to be set. */ - - -SCM -scm_shap2ra (args, what) - SCM args; - char *what; -{ - scm_array_dim *s; - SCM ra, spec, sp; - int ndim = scm_ilength (args); - SCM_ASSERT (0 <= ndim, args, s_bad_spec, what); - ra = scm_make_ra (ndim); - SCM_ARRAY_BASE (ra) = 0; - s = SCM_ARRAY_DIMS (ra); - for (; SCM_NIMP (args); s++, args = SCM_CDR (args)) - { - spec = SCM_CAR (args); - if (SCM_IMP (spec)) - - { - SCM_ASSERT (SCM_INUMP (spec) && SCM_INUM (spec) >= 0, spec, s_bad_spec, what); - s->lbnd = 0; - s->ubnd = SCM_INUM (spec) - 1; - s->inc = 1; - } - else - { - SCM_ASSERT (SCM_CONSP (spec) && SCM_INUMP (SCM_CAR (spec)), spec, s_bad_spec, what); - s->lbnd = SCM_INUM (SCM_CAR (spec)); - sp = SCM_CDR (spec); - SCM_ASSERT (SCM_INUMP (SCM_CAR (sp)) && SCM_NULLP (SCM_CDR (sp)), - spec, s_bad_spec, what); - s->ubnd = SCM_INUM (SCM_CAR (sp)); - s->inc = 1; - } - } - return ra; -} - -SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 0, 1, scm_dimensions_to_uniform_array); - -SCM -scm_dimensions_to_uniform_array (dims, prot, fill) - SCM dims; - SCM prot; - SCM fill; -{ - scm_sizet k, vlen = 1; - long rlen = 1; - scm_array_dim *s; - SCM ra; - if (SCM_INUMP (dims)) - if (SCM_INUM (dims) < SCM_LENGTH_MAX) - { - SCM answer; - answer = scm_make_uve (SCM_INUM (dims), prot); - if (SCM_NNULLP (fill)) - { - SCM_ASSERT (1 == scm_ilength (fill), - scm_makfrom0str (s_dimensions_to_uniform_array), - SCM_WNA, NULL); - scm_array_fill_x (answer, SCM_CAR (fill)); - } - else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot)) - scm_array_fill_x (answer, SCM_MAKINUM (0)); - else - scm_array_fill_x (answer, prot); - return answer; - } - else - dims = scm_cons (dims, SCM_EOL); - SCM_ASSERT (SCM_NULLP (dims) || (SCM_NIMP (dims) && SCM_CONSP (dims)), - dims, SCM_ARG1, s_dimensions_to_uniform_array); - ra = scm_shap2ra (dims, s_dimensions_to_uniform_array); - SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); - s = SCM_ARRAY_DIMS (ra); - k = SCM_ARRAY_NDIM (ra); - while (k--) - { - s[k].inc = (rlen > 0 ? rlen : 0); - rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; - vlen *= (s[k].ubnd - s[k].lbnd + 1); - } - if (rlen < SCM_LENGTH_MAX) - SCM_ARRAY_V (ra) = scm_make_uve ((rlen > 0 ? rlen : 0L), prot); - else - { - scm_sizet bit; - switch (SCM_TYP7 (scm_make_uve (0L, prot))) - { - default: - bit = SCM_LONG_BIT; - break; - case scm_tc7_bvect: - bit = 1; - break; - case scm_tc7_string: - bit = SCM_CHAR_BIT; - break; - case scm_tc7_fvect: - bit = sizeof (float) * SCM_CHAR_BIT / sizeof (char); - break; - case scm_tc7_dvect: - bit = sizeof (double) * SCM_CHAR_BIT / sizeof (char); - break; - case scm_tc7_cvect: - bit = 2 * sizeof (double) * SCM_CHAR_BIT / sizeof (char); - break; - } - SCM_ARRAY_BASE (ra) = (SCM_LONG_BIT + bit - 1) / bit; - rlen += SCM_ARRAY_BASE (ra); - SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot); - *((long *) SCM_VELTS (SCM_ARRAY_V (ra))) = rlen; - } - if (SCM_NNULLP (fill)) - { - SCM_ASSERT (1 == scm_ilength (fill), - scm_makfrom0str (s_dimensions_to_uniform_array), SCM_WNA, - NULL); - scm_array_fill_x (ra, SCM_CAR (fill)); - } - else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot)) - scm_array_fill_x (ra, SCM_MAKINUM (0)); - else - scm_array_fill_x (ra, prot); - if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) - if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc)) - return SCM_ARRAY_V (ra); - return ra; -} - - -void -scm_ra_set_contp (ra) - SCM ra; -{ - scm_sizet k = SCM_ARRAY_NDIM (ra); - if (k) - { - long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc; - while (k--) - { - if (inc != SCM_ARRAY_DIMS (ra)[k].inc) - { - SCM_SETAND_CAR (ra, ~SCM_ARRAY_CONTIGUOUS); - return; - } - inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd - - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); - } - } - SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS); -} - - -SCM_PROC(s_make_shared_array, "make-shared-array", 2, 0, 1, scm_make_shared_array); - -SCM -scm_make_shared_array (oldra, mapfunc, dims) - SCM oldra; - SCM mapfunc; - SCM dims; -{ - SCM ra; - SCM inds, indptr; - SCM imap; - scm_sizet i, k; - long old_min, new_min, old_max, new_max; - scm_array_dim *s; - SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (mapfunc), mapfunc, SCM_ARG2, s_make_shared_array); - SCM_ASSERT (SCM_NIMP (oldra) && (SCM_BOOL_F != scm_array_p (oldra, SCM_UNDEFINED)), oldra, SCM_ARG1, s_make_shared_array); - ra = scm_shap2ra (dims, s_make_shared_array); - if (SCM_ARRAYP (oldra)) - { - SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra); - old_min = old_max = SCM_ARRAY_BASE (oldra); - s = SCM_ARRAY_DIMS (oldra); - k = SCM_ARRAY_NDIM (oldra); - while (k--) - { - if (s[k].inc > 0) - old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; - else - old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; - } - } - else - { - SCM_ARRAY_V (ra) = oldra; - old_min = 0; - old_max = (long) SCM_LENGTH (oldra) - 1; - } - inds = SCM_EOL; - s = SCM_ARRAY_DIMS (ra); - for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) - { - inds = scm_cons (SCM_MAKINUM (s[k].lbnd), inds); - if (s[k].ubnd < s[k].lbnd) - { - if (1 == SCM_ARRAY_NDIM (ra)) - ra = scm_make_uve (0L, scm_array_prototype (ra)); - else - SCM_ARRAY_V (ra) = scm_make_uve (0L, scm_array_prototype (ra)); - return ra; - } - } - imap = scm_apply (mapfunc, scm_list_reverse (inds), SCM_EOL); - if (SCM_ARRAYP (oldra)) - i = (scm_sizet) scm_aind (oldra, imap, s_make_shared_array); - else - { - if (SCM_NINUMP (imap)) - - { - SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), - imap, s_bad_ind, s_make_shared_array); - imap = SCM_CAR (imap); - } - i = SCM_INUM (imap); - } - SCM_ARRAY_BASE (ra) = new_min = new_max = i; - indptr = inds; - k = SCM_ARRAY_NDIM (ra); - while (k--) - { - if (s[k].ubnd > s[k].lbnd) - { - SCM_SETCAR (indptr, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1)); - imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL); - if (SCM_ARRAYP (oldra)) - - s[k].inc = scm_aind (oldra, imap, s_make_shared_array) - i; - else - { - if (SCM_NINUMP (imap)) - - { - SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)), - imap, s_bad_ind, s_make_shared_array); - imap = SCM_CAR (imap); - } - s[k].inc = (long) SCM_INUM (imap) - i; - } - i += s[k].inc; - if (s[k].inc > 0) - new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; - else - new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; - } - else - s[k].inc = new_max - new_min + 1; /* contiguous by default */ - indptr = SCM_CDR (indptr); - } - SCM_ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED, - "mapping out of range", s_make_shared_array); - if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra)) - { - if (1 == s->inc && 0 == s->lbnd - && SCM_LENGTH (SCM_ARRAY_V (ra)) == 1 + s->ubnd) - return SCM_ARRAY_V (ra); - if (s->ubnd < s->lbnd) - return scm_make_uve (0L, scm_array_prototype (ra)); - } - scm_ra_set_contp (ra); - return ra; -} - - -/* args are RA . DIMS */ -SCM_PROC(s_transpose_array, "transpose-array", 0, 0, 1, scm_transpose_array); - -SCM -scm_transpose_array (args) - SCM args; -{ - SCM ra, res, vargs, *ve = &vargs; - scm_array_dim *s, *r; - int ndim, i, k; - SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (s_transpose_array), - SCM_WNA, NULL); - ra = SCM_CAR (args); - SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_transpose_array); - args = SCM_CDR (args); - switch (SCM_TYP7 (ra)) - { - default: - badarg:scm_wta (ra, (char *) SCM_ARGn, s_transpose_array); - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)), - scm_makfrom0str (s_transpose_array), SCM_WNA, NULL); - SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2, - s_transpose_array); - SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE, - s_transpose_array); - return ra; - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (ra), badarg); - vargs = scm_vector (args); - SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), - scm_makfrom0str (s_transpose_array), SCM_WNA, NULL); - ve = SCM_VELTS (vargs); - ndim = 0; - for (k = 0; k < SCM_ARRAY_NDIM (ra); k++) - { - i = SCM_INUM (ve[k]); - SCM_ASSERT (SCM_INUMP (ve[k]) && i >= 0 && i < SCM_ARRAY_NDIM (ra), - ve[k], SCM_ARG2, s_transpose_array); - if (ndim < i) - ndim = i; - } - ndim++; - res = scm_make_ra (ndim); - SCM_ARRAY_V (res) = SCM_ARRAY_V (ra); - SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra); - for (k = ndim; k--;) - { - SCM_ARRAY_DIMS (res)[k].lbnd = 0; - SCM_ARRAY_DIMS (res)[k].ubnd = -1; - } - for (k = SCM_ARRAY_NDIM (ra); k--;) - { - i = SCM_INUM (ve[k]); - s = &(SCM_ARRAY_DIMS (ra)[k]); - r = &(SCM_ARRAY_DIMS (res)[i]); - if (r->ubnd < r->lbnd) - { - r->lbnd = s->lbnd; - r->ubnd = s->ubnd; - r->inc = s->inc; - ndim--; - } - else - { - if (r->ubnd > s->ubnd) - r->ubnd = s->ubnd; - if (r->lbnd < s->lbnd) - { - SCM_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc; - r->lbnd = s->lbnd; - } - r->inc += s->inc; - } - } - SCM_ASSERT (ndim <= 0, args, "bad argument scm_list", s_transpose_array); - scm_ra_set_contp (res); - return res; - } -} - -/* args are RA . AXES */ -SCM_PROC(s_enclose_array, "enclose-array", 0, 0, 1, scm_enclose_array); - -SCM -scm_enclose_array (axes) - SCM axes; -{ - SCM axv, ra, res, ra_inr; - scm_array_dim vdim, *s = &vdim; - int ndim, j, k, ninr, noutr; - SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (s_enclose_array), SCM_WNA, - NULL); - ra = SCM_CAR (axes); - axes = SCM_CDR (axes); - if (SCM_NULLP (axes)) - - axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); - ninr = scm_ilength (axes); - ra_inr = scm_make_ra (ninr); - SCM_ASRTGO (SCM_NIMP (ra), badarg1); - switch SCM_TYP7 - (ra) - { - default: - badarg1:scm_wta (ra, (char *) SCM_ARG1, s_enclose_array); - case scm_tc7_string: - case scm_tc7_bvect: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_vector: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - s->lbnd = 0; - s->ubnd = SCM_LENGTH (ra) - 1; - s->inc = 1; - SCM_ARRAY_V (ra_inr) = ra; - SCM_ARRAY_BASE (ra_inr) = 0; - ndim = 1; - break; - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (ra), badarg1); - s = SCM_ARRAY_DIMS (ra); - SCM_ARRAY_V (ra_inr) = SCM_ARRAY_V (ra); - SCM_ARRAY_BASE (ra_inr) = SCM_ARRAY_BASE (ra); - ndim = SCM_ARRAY_NDIM (ra); - break; - } - noutr = ndim - ninr; - axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0)); - SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (s_enclose_array), - SCM_WNA, NULL); - res = scm_make_ra (noutr); - SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr); - SCM_ARRAY_V (res) = ra_inr; - for (k = 0; k < ninr; k++, axes = SCM_CDR (axes)) - { - SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", s_enclose_array); - j = SCM_INUM (SCM_CAR (axes)); - SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; - SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; - SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc; - SCM_CHARS (axv)[j] = 1; - } - for (j = 0, k = 0; k < noutr; k++, j++) - { - while (SCM_CHARS (axv)[j]) - j++; - SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd; - SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd; - SCM_ARRAY_DIMS (res)[k].inc = s[j].inc; - } - scm_ra_set_contp (ra_inr); - scm_ra_set_contp (res); - return res; -} - - - -SCM_PROC(s_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, scm_array_in_bounds_p); - -SCM -scm_array_in_bounds_p (args) - SCM args; -{ - SCM v, ind = SCM_EOL; - long pos = 0; - register scm_sizet k; - register long j; - scm_array_dim *s; - SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_array_in_bounds_p), - SCM_WNA, NULL); - v = SCM_CAR (args); - args = SCM_CDR (args); - SCM_ASRTGO (SCM_NIMP (v), badarg1); - if (SCM_NIMP (args)) - - { - ind = SCM_CAR (args); - args = SCM_CDR (args); - SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, s_array_in_bounds_p); - pos = SCM_INUM (ind); - } -tail: - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p); - wna: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p)); - case scm_tc7_smob: - k = SCM_ARRAY_NDIM (v); - s = SCM_ARRAY_DIMS (v); - pos = SCM_ARRAY_BASE (v); - if (!k) - { - SCM_ASRTGO (SCM_NULLP (ind), wna); - ind = SCM_INUM0; - } - else - while (!0) - { - j = SCM_INUM (ind); - if (!(j >= (s->lbnd) && j <= (s->ubnd))) - { - SCM_ASRTGO (--k == scm_ilength (args), wna); - return SCM_BOOL_F; - } - pos += (j - s->lbnd) * (s->inc); - if (!(--k && SCM_NIMP (args))) - break; - ind = SCM_CAR (args); - args = SCM_CDR (args); - s++; - SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, s_array_in_bounds_p); - } - SCM_ASRTGO (0 == k, wna); - v = SCM_ARRAY_V (v); - goto tail; - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - case scm_tc7_vector: - SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); - return pos >= 0 && pos < SCM_LENGTH (v) ? SCM_BOOL_T : SCM_BOOL_F; - } -} - - -SCM_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref); -SCM_PROC(s_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, scm_uniform_vector_ref); - -SCM -scm_uniform_vector_ref (v, args) - SCM v; - SCM args; -{ - long pos; - - if (SCM_IMP (v)) - { - SCM_ASRTGO (SCM_NULLP (args), badarg); - return v; - } - else if (SCM_ARRAYP (v)) - { - pos = scm_aind (v, args, s_uniform_vector_ref); - v = SCM_ARRAY_V (v); - } - else - { - if (SCM_NIMP (args)) - - { - SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_uniform_vector_ref); - pos = SCM_INUM (SCM_CAR (args)); - SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); - } - else - { - SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_uniform_vector_ref); - pos = SCM_INUM (args); - } - SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); - } - switch SCM_TYP7 - (v) - { - default: - if (SCM_NULLP (args)) - return v; - badarg: - scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref); - abort (); - outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref)); - case scm_tc7_smob: - { /* enclosed */ - int k = SCM_ARRAY_NDIM (v); - SCM res = scm_make_ra (k); - SCM_ARRAY_V (res) = SCM_ARRAY_V (v); - SCM_ARRAY_BASE (res) = pos; - while (k--) - { - SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd; - SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd; - SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc; - } - return res; - } - case scm_tc7_bvect: - if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) - return SCM_BOOL_T; - else - return SCM_BOOL_F; - case scm_tc7_string: - return SCM_MAKICHR (SCM_CHARS (v)[pos]); - case scm_tc7_byvect: - return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - case scm_tc7_ivect: - return SCM_MAKINUM (SCM_VELTS (v)[pos]); -# else - case scm_tc7_uvect: - return scm_ulong2num(SCM_VELTS(v)[pos]); - case scm_tc7_ivect: - return scm_long2num(SCM_VELTS(v)[pos]); -# endif - - case scm_tc7_svect: - return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); -#ifdef LONGLONGS - case scm_tc7_llvect: - return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]); -#endif - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - return scm_makflo (((float *) SCM_CDR (v))[pos]); -#endif - case scm_tc7_dvect: - return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); - case scm_tc7_cvect: - return scm_makdbl (((double *) SCM_CDR (v))[2 * pos], - ((double *) SCM_CDR (v))[2 * pos + 1]); -#endif - case scm_tc7_vector: - return SCM_VELTS (v)[pos]; - } -} - -/* Internal version of scm_uniform_vector_ref for uves that does no error checking and - tries to recycle conses. (Make *sure* you want them recycled.) */ - -SCM -scm_cvref (v, pos, last) - SCM v; - scm_sizet pos; - SCM last; -{ - switch SCM_TYP7 - (v) - { - default: - scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref"); - case scm_tc7_bvect: - if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) - return SCM_BOOL_T; - else - return SCM_BOOL_F; - case scm_tc7_string: - return SCM_MAKICHR (SCM_CHARS (v)[pos]); - case scm_tc7_byvect: - return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - case scm_tc7_ivect: - return SCM_MAKINUM (SCM_VELTS (v)[pos]); -# else - case scm_tc7_uvect: - return scm_ulong2num(SCM_VELTS(v)[pos]); - case scm_tc7_ivect: - return scm_long2num(SCM_VELTS(v)[pos]); -# endif - case scm_tc7_svect: - return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); -#ifdef LONGLONGS - case scm_tc7_llvect: - return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]); -#endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CAR (last))) - { - SCM_FLO (last) = ((float *) SCM_CDR (v))[pos]; - return last; - } - return scm_makflo (((float *) SCM_CDR (v))[pos]); -#endif - case scm_tc7_dvect: -#ifdef SCM_SINGLES - if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last)) -#else - if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last))) -#endif - { - SCM_REAL (last) = ((double *) SCM_CDR (v))[pos]; - return last; - } - return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); - case scm_tc7_cvect: - if (SCM_NIMP (last) && scm_tc_dblc == SCM_CAR (last)) - { - SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos]; - SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1]; - return last; - } - return scm_makdbl (((double *) SCM_CDR (v))[2 * pos], - ((double *) SCM_CDR (v))[2 * pos + 1]); -#endif - case scm_tc7_vector: - return SCM_VELTS (v)[pos]; - case scm_tc7_smob: - { /* enclosed scm_array */ - int k = SCM_ARRAY_NDIM (v); - SCM res = scm_make_ra (k); - SCM_ARRAY_V (res) = SCM_ARRAY_V (v); - SCM_ARRAY_BASE (res) = pos; - while (k--) - { - SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd; - SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd; - SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc; - } - return res; - } - } -} - -SCM_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x); -SCM_PROC(s_array_set_x, "array-set!", 2, 0, 1, scm_array_set_x); - -SCM -scm_array_set_x (v, obj, args) - SCM v; - SCM obj; - SCM args; -{ - long pos; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - if (SCM_ARRAYP (v)) - { - pos = scm_aind (v, args, s_array_set_x); - v = SCM_ARRAY_V (v); - } - else - { - if (SCM_NIMP (args)) - { - SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_array_set_x); - pos = SCM_INUM (SCM_CAR (args)); - SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); - } - else - { - SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_array_set_x); - pos = SCM_INUM (args); - } - SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); - } - switch (SCM_TYP7 (v)) - { - default: badarg1: - scm_wta (v, (char *) SCM_ARG1, s_array_set_x); - abort (); - outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x)); - case scm_tc7_smob: /* enclosed */ - goto badarg1; - case scm_tc7_bvect: - if (SCM_BOOL_F == obj) - SCM_VELTS (v)[pos / SCM_LONG_BIT] &= ~(1L << (pos % SCM_LONG_BIT)); - else if (SCM_BOOL_T == obj) - SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT)); - else - badarg3:scm_wta (obj, (char *) SCM_ARG3, s_array_set_x); - break; - case scm_tc7_string: - SCM_ASRTGO (SCM_ICHRP (obj), badarg3); - SCM_CHARS (v)[pos] = SCM_ICHR (obj); - break; - case scm_tc7_byvect: - if (SCM_ICHRP (obj)) - obj = SCM_MAKINUM (SCM_ICHR (obj)); - SCM_ASRTGO (SCM_INUMP (obj), badarg3); - ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj); - break; -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - SCM_ASRTGO (SCM_INUM (obj) >= 0, badarg3); - case scm_tc7_ivect: - SCM_ASRTGO(SCM_INUMP(obj), badarg3); SCM_VELTS(v)[pos] = SCM_INUM(obj); break; -# else - case scm_tc7_uvect: - SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG3, s_array_set_x); break; - case scm_tc7_ivect: - SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG3, s_array_set_x); break; -# endif - break; - - case scm_tc7_svect: - SCM_ASRTGO (SCM_INUMP (obj), badarg3); - ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj); - break; -#ifdef LONGLONGS - case scm_tc7_llvect: - ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG3, s_array_set_x); - break; -#endif - - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3); - ((float *) SCM_CDR (v))[pos] = SCM_REALPART (obj); - break; -#endif - case scm_tc7_dvect: - SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3); - ((double *) SCM_CDR (v))[pos] = SCM_REALPART (obj); - break; - case scm_tc7_cvect: - SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badarg3); - ((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj); - ((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0; - break; -#endif - case scm_tc7_vector: - SCM_VELTS (v)[pos] = obj; - break; - } - return SCM_UNSPECIFIED; -} - -SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents); - -SCM -scm_array_contents (ra, strict) - SCM ra; - SCM strict; -{ - SCM sra; - if (SCM_IMP (ra)) - return SCM_BOOL_F; - switch SCM_TYP7 - (ra) - { - default: - return SCM_BOOL_F; - case scm_tc7_vector: - case scm_tc7_string: - case scm_tc7_bvect: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_svect: -#ifdef LONGLONGS - case scm_tc7_llvect: -#endif - return ra; - case scm_tc7_smob: - { - scm_sizet k, ndim = SCM_ARRAY_NDIM (ra), len = 1; - if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra)) - return SCM_BOOL_F; - for (k = 0; k < ndim; k++) - len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; - if (!SCM_UNBNDP (strict)) - { - if SCM_ARRAY_BASE - (ra) return SCM_BOOL_F; - if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc)) - return SCM_BOOL_F; - if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra))) - { - if (len != SCM_LENGTH (SCM_ARRAY_V (ra)) || - SCM_ARRAY_BASE (ra) % SCM_LONG_BIT || - len % SCM_LONG_BIT) - return SCM_BOOL_F; - } - } - if ((len == SCM_LENGTH (SCM_ARRAY_V (ra))) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc) - return SCM_ARRAY_V (ra); - sra = scm_make_ra (1); - SCM_ARRAY_DIMS (sra)->lbnd = 0; - SCM_ARRAY_DIMS (sra)->ubnd = len - 1; - SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra); - SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra); - SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1); - return sra; - } - } -} - - -SCM -scm_ra2contig (ra, copy) - SCM ra; - int copy; -{ - SCM ret; - long inc = 1; - scm_sizet k, len = 1; - for (k = SCM_ARRAY_NDIM (ra); k--;) - len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; - k = SCM_ARRAY_NDIM (ra); - if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc))) - { - if (scm_tc7_bvect != SCM_TYP7 (ra)) - return ra; - if ((len == SCM_LENGTH (SCM_ARRAY_V (ra)) && - 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT && - 0 == len % SCM_LONG_BIT)) - return ra; - } - ret = scm_make_ra (k); - SCM_ARRAY_BASE (ret) = 0; - while (k--) - { - SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd; - SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd; - SCM_ARRAY_DIMS (ret)[k].inc = inc; - inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; - } - SCM_ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prototype (ra)); - if (copy) - scm_array_copy_x (ra, ret); - return ret; -} - - - -SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 1, 0, scm_uniform_array_read_x); - -SCM -scm_uniform_array_read_x (ra, port) - SCM ra; - SCM port; -{ - SCM cra = SCM_UNDEFINED, v = ra; - long sz, len, ans; - long start = 0; - - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINFPORTP (port), port, SCM_ARG2, - s_uniform_array_read_x); - SCM_ASRTGO (SCM_NIMP (v), badarg1); - - len = SCM_LENGTH (v); -loop: - switch SCM_TYP7 (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x); - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (v), badarg1); - cra = scm_ra2contig (ra, 0); - start = SCM_ARRAY_BASE (cra); - len = SCM_ARRAY_DIMS (cra)->inc * - (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1); - v = SCM_ARRAY_V (cra); - goto loop; - case scm_tc7_string: - case scm_tc7_byvect: - sz = sizeof (char); - break; - case scm_tc7_bvect: - len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - start /= SCM_LONG_BIT; - case scm_tc7_uvect: - case scm_tc7_ivect: - sz = sizeof (long); - break; - case scm_tc7_svect: - sz = sizeof (short); - break; -#ifdef LONGLONGS - case scm_tc7_llvect: - sz = sizeof (long_long); - break; -#endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - sz = sizeof (float); - break; -#endif - case scm_tc7_dvect: - sz = sizeof (double); - break; - case scm_tc7_cvect: - sz = 2 * sizeof (double); - break; -#endif - } - - /* An ungetc before an fread will not work on some systems if setbuf(0). - do #define NOSETBUF in scmfig.h to fix this. */ - if (SCM_CRDYP (port)) - { /* UGGH!!! */ - ungetc (SCM_CGETUN (port), (FILE *)SCM_STREAM (port)); - SCM_CLRDY (port); /* Clear ungetted char */ - } - - SCM_SYSCALL (ans = fread (SCM_CHARS (v) + start * sz, - (scm_sizet) sz, (scm_sizet) len, - (FILE *)SCM_STREAM (port))); - - if (SCM_TYP7 (v) == scm_tc7_bvect) - ans *= SCM_LONG_BIT; - - if (v != ra && cra != ra) - scm_array_copy_x (cra, ra); - - return SCM_MAKINUM (ans); -} - -SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 1, 0, scm_uniform_array_write); - -SCM -scm_uniform_array_write (v, port) - SCM v; - SCM port; -{ - long sz, len, ans; - long start = 0; - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTFPORTP (port), port, SCM_ARG2, s_uniform_array_write); - SCM_ASRTGO (SCM_NIMP (v), badarg1); - len = SCM_LENGTH (v); -loop: - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write); - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (v), badarg1); - v = scm_ra2contig (v, 1); - start = SCM_ARRAY_BASE (v); - len = SCM_ARRAY_DIMS (v)->inc * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1); - v = SCM_ARRAY_V (v); - goto loop; - case scm_tc7_byvect: - case scm_tc7_string: - sz = sizeof (char); - break; - case scm_tc7_bvect: - len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - start /= SCM_LONG_BIT; - case scm_tc7_uvect: - case scm_tc7_ivect: - sz = sizeof (long); - break; - case scm_tc7_svect: - sz = sizeof (short); - break; -#ifdef LONGLONGS - case scm_tc7_llvect: - sz = sizeof (long_long); - break; -#endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - sz = sizeof (float); - break; -#endif - case scm_tc7_dvect: - sz = sizeof (double); - break; - case scm_tc7_cvect: - sz = 2 * sizeof (double); - break; -#endif - } - SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port))); - if (SCM_TYP7 (v) == scm_tc7_bvect) - ans *= SCM_LONG_BIT; - return SCM_MAKINUM (ans); -} - - -static char cnt_tab[16] = -{0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; - -SCM_PROC(s_bit_count, "bit-count", 2, 0, 0, scm_bit_count); - -SCM -scm_bit_count (item, seq) - SCM item; - SCM seq; -{ - long i; - register unsigned long cnt = 0, w; - SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count); - switch SCM_TYP7 - (seq) - { - default: - scm_wta (seq, (char *) SCM_ARG2, s_bit_count); - case scm_tc7_bvect: - if (0 == SCM_LENGTH (seq)) - return SCM_INUM0; - i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT; - w = SCM_VELTS (seq)[i]; - if (SCM_FALSEP (item)) - w = ~w; - w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT); - while (!0) - { - for (; w; w >>= 4) - cnt += cnt_tab[w & 0x0f]; - if (0 == i--) - return SCM_MAKINUM (cnt); - w = SCM_VELTS (seq)[i]; - if (SCM_FALSEP (item)) - w = ~w; - } - } -} - - -SCM_PROC(s_bit_position, "bit-position", 3, 0, 0, scm_bit_position); - -SCM -scm_bit_position (item, v, k) - SCM item; - SCM v; - SCM k; -{ - long i, lenw, xbits, pos = SCM_INUM (k); - register unsigned long w; - SCM_ASSERT (SCM_NIMP (v), v, SCM_ARG2, s_bit_position); - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG3, s_bit_position); - SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0), - k, SCM_OUTOFRANGE, s_bit_position); - if (pos == SCM_LENGTH (v)) - return SCM_BOOL_F; - switch SCM_TYP7 - (v) - { - default: - scm_wta (v, (char *) SCM_ARG2, s_bit_position); - case scm_tc7_bvect: - if (0 == SCM_LENGTH (v)) - return SCM_MAKINUM (-1L); - lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ - i = pos / SCM_LONG_BIT; - w = SCM_VELTS (v)[i]; - if (SCM_FALSEP (item)) - w = ~w; - xbits = (pos % SCM_LONG_BIT); - pos -= xbits; - w = ((w >> xbits) << xbits); - xbits = SCM_LONG_BIT - 1 - (SCM_LENGTH (v) - 1) % SCM_LONG_BIT; - while (!0) - { - if (w && (i == lenw)) - w = ((w << xbits) >> xbits); - if (w) - while (w) - switch (w & 0x0f) - { - default: - return SCM_MAKINUM (pos); - case 2: - case 6: - case 10: - case 14: - return SCM_MAKINUM (pos + 1); - case 4: - case 12: - return SCM_MAKINUM (pos + 2); - case 8: - return SCM_MAKINUM (pos + 3); - case 0: - pos += 4; - w >>= 4; - } - if (++i > lenw) - break; - pos += SCM_LONG_BIT; - w = SCM_VELTS (v)[i]; - if (SCM_FALSEP (item)) - w = ~w; - } - return SCM_BOOL_F; - } -} - - -SCM_PROC(s_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_bit_set_star_x); - -SCM -scm_bit_set_star_x (v, kv, obj) - SCM v; - SCM kv; - SCM obj; -{ - register long i, k, vlen; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - SCM_ASRTGO (SCM_NIMP (kv), badarg2); - switch SCM_TYP7 - (kv) - { - default: - badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x); - case scm_tc7_uvect: - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x); - case scm_tc7_bvect: - vlen = SCM_LENGTH (v); - if (SCM_BOOL_F == obj) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x); - SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT)); - } - else if (SCM_BOOL_T == obj) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x); - SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT)); - } - else - badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_set_star_x); - } - break; - case scm_tc7_bvect: - SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); - if (SCM_BOOL_F == obj) - for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] &= ~(SCM_VELTS (kv)[k]); - else if (SCM_BOOL_T == obj) - for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] |= SCM_VELTS (kv)[k]; - else - goto badarg3; - break; - } - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_bit_count_star, "bit-count*", 3, 0, 0, scm_bit_count_star); - -SCM -scm_bit_count_star (v, kv, obj) - SCM v; - SCM kv; - SCM obj; -{ - register long i, vlen, count = 0; - register unsigned long k; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - SCM_ASRTGO (SCM_NIMP (kv), badarg2); - switch SCM_TYP7 - (kv) - { - default: - badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star); - case scm_tc7_uvect: - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_count_star); - case scm_tc7_bvect: - vlen = SCM_LENGTH (v); - if (SCM_BOOL_F == obj) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star); - if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))) - count++; - } - else if (SCM_BOOL_T == obj) - for (i = SCM_LENGTH (kv); i;) - { - k = SCM_VELTS (kv)[--i]; - SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star); - if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))) - count++; - } - else - badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_count_star); - } - break; - case scm_tc7_bvect: - SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); - if (0 == SCM_LENGTH (v)) - return SCM_INUM0; - SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3); - obj = (SCM_BOOL_T == obj); - i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; - k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]); - k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT); - while (!0) - { - for (; k; k >>= 4) - count += cnt_tab[k & 0x0f]; - if (0 == i--) - return SCM_MAKINUM (count); - k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]); - } - } - return SCM_MAKINUM (count); -} - - -SCM_PROC(s_bit_invert_x, "bit-invert!", 1, 0, 0, scm_bit_invert_x); - -SCM -scm_bit_invert_x (v) - SCM v; -{ - register long k; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - k = SCM_LENGTH (v); - switch SCM_TYP7 - (v) - { - case scm_tc7_bvect: - for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k]; - break; - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_invert_x); - } - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_string_upcase_x, "string-upcase!", 1, 0, 0, scm_string_upcase_x); - -SCM -scm_string_upcase_x (v) - SCM v; -{ - register long k; - register unsigned char *cs; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - k = SCM_LENGTH (v); - switch SCM_TYP7 - (v) - { - case scm_tc7_string: - cs = SCM_UCHARS (v); - while (k--) - cs[k] = scm_upcase(cs[k]); - break; - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_upcase_x); - } - return v; -} - -SCM_PROC(s_string_downcase_x, "string-downcase!", 1, 0, 0, scm_string_downcase_x); - -SCM -scm_string_downcase_x (v) - SCM v; -{ - register long k; - register unsigned char *cs; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - k = SCM_LENGTH (v); - switch SCM_TYP7 - (v) - { - case scm_tc7_string: - cs = SCM_UCHARS (v); - while (k--) - cs[k] = scm_downcase(cs[k]); - break; - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_downcase_x); - } - return v; -} - - - -SCM -scm_istr2bve (str, len) - char *str; - long len; -{ - SCM v = scm_make_uve (len, SCM_BOOL_T); - long *data = (long *) SCM_VELTS (v); - register unsigned long mask; - register long k; - register long j; - for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++) - { - data[k] = 0L; - j = len - k * SCM_LONG_BIT; - if (j > SCM_LONG_BIT) - j = SCM_LONG_BIT; - for (mask = 1L; j--; mask <<= 1) - switch (*str++) - { - case '0': - break; - case '1': - data[k] |= mask; - break; - default: - return SCM_BOOL_F; - } - } - return v; -} - - - -static SCM ra2l SCM_P ((SCM ra, scm_sizet base, scm_sizet k)); - -static SCM -ra2l (ra, base, k) - SCM ra; - scm_sizet base; - scm_sizet k; -{ - register SCM res = SCM_EOL; - register long inc = SCM_ARRAY_DIMS (ra)[k].inc; - register scm_sizet i; - if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd) - return SCM_EOL; - i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc; - if (k < SCM_ARRAY_NDIM (ra) - 1) - { - do - { - i -= inc; - res = scm_cons (ra2l (ra, i, k + 1), res); - } - while (i != base); - } - else - do - { - i -= inc; - res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_MAKINUM (i)), res); - } - while (i != base); - return res; -} - - -SCM_PROC(s_array_to_list, "array->list", 1, 0, 0, scm_array_to_list); - -SCM -scm_array_to_list (v) - SCM v; -{ - SCM res = SCM_EOL; - register long k; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - switch SCM_TYP7 - (v) - { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_to_list); - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (v), badarg1); - return ra2l (v, SCM_ARRAY_BASE (v), 0); - case scm_tc7_vector: - return scm_vector_to_list (v); - case scm_tc7_string: - return scm_string_to_list (v); - case scm_tc7_bvect: - { - long *data = (long *) SCM_VELTS (v); - register unsigned long mask; - for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--) - for (mask = 1L << (SCM_LONG_BIT - 1); mask; mask >>= 1) - res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res); - for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1) - res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res); - return res; - } -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *data = (long *) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (SCM_MAKINUM (data[k]), res); - return res; - } -# else - case scm_tc7_uvect: { - long *data = (long *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_ulong2num(data[k]), res); - return res; - } - case scm_tc7_ivect: { - long *data = (long *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_long2num(data[k]), res); - return res; - } -# endif - case scm_tc7_svect: { - short *data; - data = (short *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(SCM_MAKINUM (data[k]), res); - return res; - } -#ifdef LONGLONGS - case scm_tc7_llvect: { - long_long *data; - data = (long_long *)SCM_VELTS(v); - for (k = SCM_LENGTH(v) - 1; k >= 0; k--) - res = scm_cons(scm_long_long2num(data[k]), res); - return res; - } -#endif - - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *data = (float *) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (scm_makflo (data[k]), res); - return res; - } -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - { - double *data = (double *) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (scm_makdbl (data[k], 0.0), res); - return res; - } - case scm_tc7_cvect: - { - double (*data)[2] = (double (*)[2]) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res); - return res; - } -#endif /*SCM_FLOATS*/ - } -} - - -static char s_bad_ralst[] = "Bad scm_array contents scm_list"; - -static int l2ra SCM_P ((SCM lst, SCM ra, scm_sizet base, scm_sizet k)); - -SCM_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array); - -SCM -scm_list_to_uniform_array (ndim, prot, lst) - SCM ndim; - SCM prot; - SCM lst; -{ - SCM shp = SCM_EOL; - SCM row = lst; - SCM ra; - scm_sizet k; - long n; - SCM_ASSERT (SCM_INUMP (ndim), ndim, SCM_ARG1, s_list_to_uniform_array); - k = SCM_INUM (ndim); - while (k--) - { - n = scm_ilength (row); - SCM_ASSERT (n >= 0, lst, SCM_ARG2, s_list_to_uniform_array); - shp = scm_cons (SCM_MAKINUM (n), shp); - if (SCM_NIMP (row)) - row = SCM_CAR (row); - } - ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot, SCM_EOL); - if (SCM_NULLP (shp)) - - { - SCM_ASRTGO (1 == scm_ilength (lst), badlst); - scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL); - return ra; - } - if (!SCM_ARRAYP (ra)) - { - for (k = 0; k < SCM_LENGTH (ra); k++, lst = SCM_CDR (lst)) - scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k)); - return ra; - } - if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0)) - return ra; - else - badlst:scm_wta (lst, s_bad_ralst, s_list_to_uniform_array); - return SCM_BOOL_F; -} - -static int -l2ra (lst, ra, base, k) - SCM lst; - SCM ra; - scm_sizet base; - scm_sizet k; -{ - register long inc = SCM_ARRAY_DIMS (ra)[k].inc; - register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd); - int ok = 1; - if (n <= 0) - return (SCM_EOL == lst); - if (k < SCM_ARRAY_NDIM (ra) - 1) - { - while (n--) - { - if (SCM_IMP (lst) || SCM_NCONSP (lst)) - return 0; - ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1); - base += inc; - lst = SCM_CDR (lst); - } - if (SCM_NNULLP (lst)) - return 0; - } - else - { - while (n--) - { - if (SCM_IMP (lst) || SCM_NCONSP (lst)) - return 0; - ok = ok && scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base)); - base += inc; - lst = SCM_CDR (lst); - } - if (SCM_NNULLP (lst)) - return 0; - } - return ok; -} - - -static void rapr1 SCM_P ((SCM ra, scm_sizet j, scm_sizet k, SCM port, scm_print_state *pstate)); - -static void -rapr1 (ra, j, k, port, pstate) - SCM ra; - scm_sizet j; - scm_sizet k; - SCM port; - scm_print_state *pstate; -{ - long inc = 1; - long n = SCM_LENGTH (ra); - int enclosed = 0; -tail: - switch SCM_TYP7 - (ra) - { - case scm_tc7_smob: - if (enclosed++) - { - SCM_ARRAY_BASE (ra) = j; - if (n-- > 0) - scm_iprin1 (ra, port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - SCM_ARRAY_BASE (ra) = j; - scm_iprin1 (ra, port, pstate); - } - break; - } - if (k + 1 < SCM_ARRAY_NDIM (ra)) - { - long i; - inc = SCM_ARRAY_DIMS (ra)[k].inc; - for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++) - { - scm_gen_putc ('(', port); - rapr1 (ra, j, k + 1, port, pstate); - scm_gen_puts (scm_regular_string, ") ", port); - j += inc; - } - if (i == SCM_ARRAY_DIMS (ra)[k].ubnd) - { /* could be zero size. */ - scm_gen_putc ('(', port); - rapr1 (ra, j, k + 1, port, pstate); - scm_gen_putc (')', port); - } - break; - } - if SCM_ARRAY_NDIM - (ra) - { /* Could be zero-dimensional */ - inc = SCM_ARRAY_DIMS (ra)[k].inc; - n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); - } - else - n = 1; - ra = SCM_ARRAY_V (ra); - goto tail; - default: - if (n-- > 0) - scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate); - } - break; - case scm_tc7_string: - if (n-- > 0) - scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate); - if (SCM_WRITINGP (pstate)) - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate); - } - else - for (j += inc; n-- > 0; j += inc) - scm_gen_putc (SCM_CHARS (ra)[j], port); - break; - case scm_tc7_byvect: - if (n-- > 0) - scm_intprint (((char *)SCM_CDR (ra))[j], 10, port); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - scm_intprint (((char *)SCM_CDR (ra))[j], 10, port); - } - break; - - case scm_tc7_uvect: - case scm_tc7_ivect: - if (n-- > 0) - scm_intprint (SCM_VELTS (ra)[j], 10, port); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - scm_intprint (SCM_VELTS (ra)[j], 10, port); - } - break; - - case scm_tc7_svect: - if (n-- > 0) - scm_intprint (((short *)SCM_CDR (ra))[j], 10, port); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - scm_intprint (((short *)SCM_CDR (ra))[j], 10, port); - } - break; - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - if (n-- > 0) - { - SCM z = scm_makflo (1.0); - SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); - } - } - break; -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - if (n-- > 0) - { - SCM z = scm_makdbl (1.0 / 3.0, 0.0); - SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); - } - } - break; - case scm_tc7_cvect: - if (n-- > 0) - { - SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0); - SCM_REAL (z) = SCM_REAL (cz) = (((double *) SCM_VELTS (ra))[2 * j]); - SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; - scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate); - for (j += inc; n-- > 0; j += inc) - { - scm_gen_putc (' ', port); - SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j]; - SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; - scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate); - } - } - break; -#endif /*SCM_FLOATS*/ - } -} - - - -int -scm_raprin1 (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - SCM v = exp; - scm_sizet base = 0; - scm_gen_putc ('#', port); -tail: - switch SCM_TYP7 - (v) - { - case scm_tc7_smob: - { - long ndim = SCM_ARRAY_NDIM (v); - base = SCM_ARRAY_BASE (v); - v = SCM_ARRAY_V (v); - if (SCM_ARRAYP (v)) - - { - scm_gen_puts (scm_regular_string, "<enclosed-array ", port); - rapr1 (exp, base, 0, port, pstate); - scm_gen_putc ('>', port); - return 1; - } - else - { - scm_intprint (ndim, 10, port); - goto tail; - } - } - case scm_tc7_bvect: - if (exp == v) - { /* a uve, not an scm_array */ - register long i, j, w; - scm_gen_putc ('*', port); - for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++) - { - w = SCM_VELTS (exp)[i]; - for (j = SCM_LONG_BIT; j; j--) - { - scm_gen_putc (w & 1 ? '1' : '0', port); - w >>= 1; - } - } - j = SCM_LENGTH (exp) % SCM_LONG_BIT; - if (j) - { - w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT]; - for (; j; j--) - { - scm_gen_putc (w & 1 ? '1' : '0', port); - w >>= 1; - } - } - return 1; - } - else - scm_gen_putc ('b', port); - break; - case scm_tc7_string: - scm_gen_putc ('a', port); - break; - case scm_tc7_byvect: - scm_gen_puts (scm_regular_string, "bytes", port); - break; - case scm_tc7_uvect: - scm_gen_putc ('u', port); - break; - case scm_tc7_ivect: - scm_gen_putc ('e', port); - break; - case scm_tc7_svect: - scm_gen_puts (scm_regular_string, "short", port); - break; -#ifdef LONGLONGS - case scm_tc7_llvect: - scm_gen_puts (scm_regular_string, "long_long", port); - break; -#endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - scm_gen_putc ('s', port); - break; -#endif /*SCM_SINGLES*/ - case scm_tc7_dvect: - scm_gen_putc ('i', port); - break; - case scm_tc7_cvect: - scm_gen_putc ('c', port); - break; -#endif /*SCM_FLOATS*/ - } - scm_gen_putc ('(', port); - rapr1 (exp, base, 0, port, pstate); - scm_gen_putc (')', port); - return 1; -} - -SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype); - -SCM -scm_array_prototype (ra) - SCM ra; -{ - int enclosed = 0; - SCM_ASRTGO (SCM_NIMP (ra), badarg); -loop: - switch SCM_TYP7 - (ra) - { - default: - badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_prototype); - case scm_tc7_smob: - SCM_ASRTGO (SCM_ARRAYP (ra), badarg); - if (enclosed++) - return SCM_UNSPECIFIED; - ra = SCM_ARRAY_V (ra); - goto loop; - case scm_tc7_vector: - return SCM_EOL; - case scm_tc7_bvect: - return SCM_BOOL_T; - case scm_tc7_string: - return SCM_MAKICHR ('a'); - case scm_tc7_byvect: - return SCM_MAKICHR ('\0'); - case scm_tc7_uvect: - return SCM_MAKINUM (1L); - case scm_tc7_ivect: - return SCM_MAKINUM (-1L); - case scm_tc7_svect: - return SCM_CDR (scm_intern ("s", 1)); -#ifdef LONGLONGS - case scm_tc7_llvect: - return SCM_CDR (scm_intern ("l", 1)); -#endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - return scm_makflo (1.0); -#endif - case scm_tc7_dvect: - return scm_makdbl (1.0 / 3.0, 0.0); - case scm_tc7_cvect: - return scm_makdbl (0.0, 1.0); -#endif - } -} - - -static SCM markra SCM_P ((SCM ptr)); - -static SCM -markra (ptr) - SCM ptr; -{ - if SCM_GC8MARKP - (ptr) return SCM_BOOL_F; - SCM_SETGC8MARK (ptr); - return SCM_ARRAY_V (ptr); -} - - -static scm_sizet freera SCM_P ((SCM ptr)); - -static scm_sizet -freera (ptr) - SCM ptr; -{ - scm_must_free (SCM_CHARS (ptr)); - return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim); -} - -static scm_smobfuns rasmob = -{markra, freera, scm_raprin1, scm_array_equal_p}; - - -/* This must be done after scm_init_scl() */ - -void -scm_init_unif () -{ -#include "unif.x" - scm_tc16_array = scm_newsmob (&rasmob); - scm_add_feature ("array"); -} - -#else /* ARRAYS */ - - -int -scm_raprin1 (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - return 0; -} - - -SCM -scm_istr2bve (str, len) - char *str; - long len; -{ - return SCM_BOOL_F; -} - -void -scm_init_unif () -{ - scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x); -} - -#endif /* ARRAYS */ diff --git a/libguile/unif.h b/libguile/unif.h deleted file mode 100644 index 45aef3fe2..000000000 --- a/libguile/unif.h +++ /dev/null @@ -1,114 +0,0 @@ -/* classes: h_files */ - -#ifndef UNIFH -#define UNIFH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - -typedef struct scm_array -{ - SCM v; - scm_sizet base; -} scm_array; - -typedef struct scm_array_dim -{ - long lbnd; - long ubnd; - long inc; -} scm_array_dim; - - -extern long scm_tc16_array; -#define SCM_ARRAYP(a) (scm_tc16_array==SCM_TYP16(a)) -#define SCM_ARRAY_V(a) (((scm_array *)SCM_CDR(a))->v) -#define SCM_ARRAY_NDIM(x) ((scm_sizet)(SCM_CAR(x)>>17)) -#define SCM_ARRAY_CONTIGUOUS 0x10000 -#define SCM_ARRAY_CONTP(x) (SCM_ARRAY_CONTIGUOUS & (int)SCM_CAR(x)) -#define SCM_ARRAY_BASE(a) (((scm_array *)SCM_CDR(a))->base) -#define SCM_ARRAY_DIMS(a) ((scm_array_dim *)(SCM_CHARS(a)+sizeof(scm_array))) - -#define SCM_HUGE_LENGTH(x) (SCM_LENGTH_MAX==SCM_LENGTH(x) ? *((long *)SCM_VELTS(x)) : SCM_LENGTH(x)) - - - -extern SCM scm_vector_set_length_x SCM_P ((SCM vect, SCM len)); -extern SCM scm_makflo SCM_P ((float x)); -extern SCM scm_make_uve SCM_P ((long k, SCM prot)); -extern SCM scm_uniform_vector_length SCM_P ((SCM v)); -extern SCM scm_array_p SCM_P ((SCM v, SCM prot)); -extern SCM scm_array_rank SCM_P ((SCM ra)); -extern SCM scm_array_dimensions SCM_P ((SCM ra)); -extern long scm_aind SCM_P ((SCM ra, SCM args, char *what)); -extern SCM scm_make_ra SCM_P ((int ndim)); -extern SCM scm_shap2ra SCM_P ((SCM args, char *what)); -extern SCM scm_dimensions_to_uniform_array SCM_P ((SCM dims, SCM prot, SCM fill)); -extern void scm_ra_set_contp SCM_P ((SCM ra)); -extern SCM scm_make_shared_array SCM_P ((SCM oldra, SCM mapfunc, SCM dims)); -extern SCM scm_transpose_array SCM_P ((SCM args)); -extern SCM scm_enclose_array SCM_P ((SCM axes)); -extern SCM scm_array_in_bounds_p SCM_P ((SCM args)); -extern SCM scm_uniform_vector_ref SCM_P ((SCM v, SCM args)); -extern SCM scm_cvref SCM_P ((SCM v, scm_sizet pos, SCM last)); -extern SCM scm_array_set_x SCM_P ((SCM v, SCM obj, SCM args)); -extern SCM scm_array_contents SCM_P ((SCM ra, SCM strict)); -extern SCM scm_ra2contig SCM_P ((SCM ra, int copy)); -extern SCM scm_uniform_array_read_x SCM_P ((SCM ra, SCM port)); -extern SCM scm_uniform_array_write SCM_P ((SCM v, SCM port)); -extern SCM scm_bit_count SCM_P ((SCM item, SCM seq)); -extern SCM scm_bit_position SCM_P ((SCM item, SCM v, SCM k)); -extern SCM scm_bit_set_star_x SCM_P ((SCM v, SCM kv, SCM obj)); -extern SCM scm_bit_count_star SCM_P ((SCM v, SCM kv, SCM obj)); -extern SCM scm_bit_invert_x SCM_P ((SCM v)); -extern SCM scm_string_upcase_x SCM_P ((SCM v)); -extern SCM scm_string_downcase_x SCM_P ((SCM v)); -extern SCM scm_istr2bve SCM_P ((char *str, long len)); -extern SCM scm_array_to_list SCM_P ((SCM v)); -extern SCM scm_list_to_uniform_array SCM_P ((SCM ndim, SCM prot, SCM lst)); -extern int scm_raprin1 SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); -extern SCM scm_array_prototype SCM_P ((SCM ra)); -extern void scm_init_unif SCM_P ((void)); - -#endif /* UNIFH */ diff --git a/libguile/variable.c b/libguile/variable.c deleted file mode 100644 index 692219c0a..000000000 --- a/libguile/variable.c +++ /dev/null @@ -1,249 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "genio.h" -#include "smob.h" - -#include "variable.h" - - -static scm_sizet free_var SCM_P ((SCM obj)); - -static scm_sizet -free_var (obj) - SCM obj; -{ - return 0; -} - - - -static int prin_var SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prin_var (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_gen_puts (scm_regular_string, "#<variable ", port); - scm_intprint(exp, 16, port); - { - SCM val_cell; - val_cell = SCM_CDR(exp); - if (SCM_CAR (val_cell) != SCM_UNDEFINED) - { - scm_gen_puts (scm_regular_string, " name: ", port); - scm_iprin1 (SCM_CAR (val_cell), port, pstate); - } - scm_gen_puts (scm_regular_string, " binding: ", port); - scm_iprin1 (SCM_CDR (val_cell), port, pstate); - } - scm_gen_putc('>', port); - return 1; -} - - -static SCM scm_markvar SCM_P ((SCM ptr)); - -static SCM -scm_markvar (ptr) - SCM ptr; -{ - if (SCM_GC8MARKP (ptr)) - return SCM_BOOL_F; - SCM_SETGC8MARK (ptr); - return SCM_CDR (ptr); -} - -int scm_tc16_variable; -static scm_smobfuns variable_smob = {scm_markvar, free_var, prin_var, 0}; - - -static SCM anonymous_variable_sym; - - -static SCM make_vcell_variable SCM_P ((SCM vcell)); - -static SCM -make_vcell_variable (vcell) - SCM vcell; -{ - SCM answer; - SCM_NEWCELL(answer); - SCM_REDEFER_INTS; - SCM_SETCAR (answer, scm_tc16_variable); - SCM_SETCDR (answer, vcell); - SCM_REALLOW_INTS; - return answer; -} - -SCM_PROC(s_make_variable, "make-variable", 1, 1, 0, scm_make_variable); - -SCM -scm_make_variable (init, name_hint) - SCM init; - SCM name_hint; -{ - SCM val_cell; - - if (name_hint == SCM_UNDEFINED) - name_hint = anonymous_variable_sym; - - SCM_NEWCELL(val_cell); - SCM_DEFER_INTS; - SCM_SETCAR (val_cell, name_hint); - SCM_SETCDR (val_cell, init); - SCM_ALLOW_INTS; - return make_vcell_variable (val_cell); -} - - -SCM_PROC(s_make_undefined_variable, "make-undefined-variable", 0, 1, 0, scm_make_undefined_variable); - -SCM -scm_make_undefined_variable (name_hint) - SCM name_hint; -{ - SCM vcell; - - if (name_hint == SCM_UNDEFINED) - name_hint = anonymous_variable_sym; - - SCM_NEWCELL (vcell); - SCM_DEFER_INTS; - SCM_SETCAR (vcell, name_hint); - SCM_SETCDR (vcell, SCM_UNDEFINED); - SCM_ALLOW_INTS; - return make_vcell_variable (vcell); -} - - -SCM_PROC(s_variable_p, "variable?", 1, 0, 0, scm_variable_p); - -SCM -scm_variable_p (obj) - SCM obj; -{ - return ( (SCM_NIMP(obj) && SCM_VARIABLEP (obj)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC(s_variable_ref, "variable-ref", 1, 0, 0, scm_variable_ref); - -SCM -scm_variable_ref (var) - SCM var; -{ - SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP(var), var, SCM_ARG1, s_variable_ref); - return SCM_CDR (SCM_CDR (var)); -} - - - -SCM_PROC(s_variable_set_x, "variable-set!", 2, 0, 0, scm_variable_set_x); - -SCM -scm_variable_set_x (var, val) - SCM var; - SCM val; -{ - SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_set_x); - SCM_SETCDR (SCM_CDR (var), val); - return SCM_UNSPECIFIED; -} - - -SCM_PROC(s_builtin_variable, "builtin-variable", 1, 0, 0, scm_builtin_variable); - -SCM -scm_builtin_variable (name) - SCM name; -{ - SCM vcell; - SCM var_slot; - - SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_builtin_variable); - vcell = scm_sym2vcell (name, SCM_BOOL_F, SCM_BOOL_T); - if (vcell == SCM_BOOL_F) - return SCM_BOOL_F; - - scm_intern_symbol (scm_symhash_vars, name); - var_slot = scm_sym2ovcell (name, scm_symhash_vars); - - SCM_DEFER_INTS; - if ( SCM_IMP (SCM_CDR (var_slot)) - || (SCM_VARVCELL (var_slot) != vcell)) - SCM_SETCDR (var_slot, make_vcell_variable (vcell)); - SCM_ALLOW_INTS; - - return SCM_CDR (var_slot); -} - - -SCM_PROC(s_variable_bound_p, "variable-bound?", 1, 0, 0, scm_variable_bound_p); - -SCM -scm_variable_bound_p (var) - SCM var; -{ - SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_bound_p); - return (SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var))) - ? SCM_BOOL_F - : SCM_BOOL_T); -} - - - - -void -scm_init_variable () -{ - scm_tc16_variable = scm_newsmob (&variable_smob); - anonymous_variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED)); -#include "variable.x" -} - diff --git a/libguile/variable.h b/libguile/variable.h deleted file mode 100644 index 9bced2936..000000000 --- a/libguile/variable.h +++ /dev/null @@ -1,71 +0,0 @@ -/* classes: h_files */ - -#ifndef VARIABLEH -#define VARIABLEH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include "libguile/__scm.h" - - - - -/* Variables - */ -extern int scm_tc16_variable; - -#define SCM_VARVCELL(V) SCM_CDR(V) -#define SCM_VARIABLEP(X) (scm_tc16_variable == SCM_CAR(X)) -#define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) -#define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) - - - -extern SCM scm_make_variable SCM_P ((SCM init, SCM name_hint)); -extern SCM scm_make_undefined_variable SCM_P ((SCM name_hint)); -extern SCM scm_variable_p SCM_P ((SCM obj)); -extern SCM scm_variable_ref SCM_P ((SCM var)); -extern SCM scm_variable_set_x SCM_P ((SCM var, SCM val)); -extern SCM scm_builtin_variable SCM_P ((SCM name)); -extern SCM scm_variable_bound_p SCM_P ((SCM var)); -extern void scm_init_variable SCM_P ((void)); - -#endif /* VARIABLEH */ diff --git a/libguile/vectors.c b/libguile/vectors.c deleted file mode 100644 index 4484bf841..000000000 --- a/libguile/vectors.c +++ /dev/null @@ -1,271 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "eq.h" - -#include "vectors.h" - - - -SCM_PROC(s_vector_p, "vector?", 1, 0, 0, scm_vector_p); - -SCM -scm_vector_p(x) - SCM x; -{ - if SCM_IMP(x) return SCM_BOOL_F; - return SCM_VECTORP(x) ? SCM_BOOL_T : SCM_BOOL_F; -} - -SCM_PROC(s_vector_length, "vector-length", 1, 0, 0, scm_vector_length); - -SCM -scm_vector_length(v) - SCM v; -{ - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_length); - return SCM_MAKINUM(SCM_LENGTH(v)); -} - -SCM_PROC(s_list_to_vector, "list->vector", 1, 0, 0, scm_vector); -SCM_PROC(s_vector, "vector", 0, 0, 1, scm_vector); - -SCM -scm_vector(l) - SCM l; -{ - SCM res; - register SCM *data; - long i = scm_ilength(l); - SCM_ASSERT(i >= 0, l, SCM_ARG1, s_vector); - res = scm_make_vector(SCM_MAKINUM(i), SCM_UNSPECIFIED, SCM_UNDEFINED); - data = SCM_VELTS(res); - for(;i && SCM_NIMP(l);--i, l = SCM_CDR(l)) - *data++ = SCM_CAR(l); - return res; -} - -SCM_PROC(s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref); - -SCM -scm_vector_ref(v, k) - SCM v; - SCM k; -{ - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_ref); - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_vector_ref); - SCM_ASSERT((SCM_INUM(k) < SCM_LENGTH(v)) && (SCM_INUM(k) >= 0), k, SCM_OUTOFRANGE, s_vector_ref); - return SCM_VELTS(v)[((long) SCM_INUM(k))]; -} - - -SCM_PROC(s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x); - -SCM -scm_vector_set_x(v, k, obj) - SCM v; - SCM k; - SCM obj; -{ - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_set_x); - SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_vector_set_x); - SCM_ASSERT((SCM_INUM(k) < SCM_LENGTH(v)) && (SCM_INUM(k) >= 0), k, SCM_OUTOFRANGE, s_vector_set_x); - SCM_VELTS(v)[((long) SCM_INUM(k))] = obj; - return obj; -} - - -SCM_PROC(s_make_vector, "make-vector", 1, 2, 0, scm_make_vector); - -SCM -scm_make_vector(k, fill, multip) - SCM k; - SCM fill; - SCM multip; -{ - SCM v; - int multi; - register long i; - register long j; - register SCM *velts; - - SCM_ASSERT(SCM_INUMP(k) && (0 <= SCM_INUM (k)), k, SCM_ARG1, s_make_vector); - if (SCM_UNBNDP(fill)) - fill = SCM_UNSPECIFIED; - multi = !(SCM_UNBNDP(multip) || SCM_FALSEP(multip)); - i = SCM_INUM(k); - SCM_NEWCELL(v); - SCM_DEFER_INTS; - SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector)); - SCM_SETLENGTH(v, i, scm_tc7_vector); - velts = SCM_VELTS(v); - j = 0; - if (multi) - { - while ((fill != SCM_EOL) && (j < i)) - { - (velts)[j++] = SCM_CAR (fill); - fill = SCM_CDR (fill); - } - } - while(--i >= j) (velts)[i] = fill; - SCM_ALLOW_INTS; - return v; -} - - -SCM_PROC(s_vector_to_list, "vector->list", 1, 0, 0, scm_vector_to_list); - -SCM -scm_vector_to_list(v) - SCM v; -{ - SCM res = SCM_EOL; - long i; - SCM *data; - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_to_list); - data = SCM_VELTS(v); - for(i = SCM_LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res); - return res; -} - - -SCM_PROC(s_vector_fill_x, "vector-fill!", 2, 0, 0, scm_vector_fill_x); - -SCM -scm_vector_fill_x(v, fill_x) - SCM v; - SCM fill_x; -{ - register long i; - register SCM *data; - SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_fill_x); - data = SCM_VELTS(v); - for(i = SCM_LENGTH(v)-1;i >= 0;i--) data[i] = fill_x; - return SCM_UNSPECIFIED; -} - - - -SCM -scm_vector_equal_p(x, y) - SCM x; - SCM y; -{ - long i; - for(i = SCM_LENGTH(x)-1;i >= 0;i--) - if (SCM_FALSEP(scm_equal_p(SCM_VELTS(x)[i], SCM_VELTS(y)[i]))) - return SCM_BOOL_F; - return SCM_BOOL_T; -} - - -SCM_PROC (s_vector_move_left_x, "vector-move-left!", 5, 0, 0, scm_vector_move_left_x); - -SCM -scm_vector_move_left_x (vec1, start1, end1, vec2, start2) - SCM vec1; - SCM start1; - SCM end1; - SCM vec2; - SCM start2; -{ - long i; - long j; - long e; - - SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_left_x); - SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_left_x); - SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_left_x); - SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_left_x); - SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_left_x); - i = SCM_INUM (start1); - j = SCM_INUM (start2); - e = SCM_INUM (end1); - SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_left_x); - SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_left_x); - SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_left_x); - SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_left_x); - while (i<e) SCM_VELTS (vec2)[j++] = SCM_VELTS (vec1)[i++]; - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_vector_move_right_x, "vector-move-right!", 5, 0, 0, scm_vector_move_right_x); - -SCM -scm_vector_move_right_x (vec1, start1, end1, vec2, start2) - SCM vec1; - SCM start1; - SCM end1; - SCM vec2; - SCM start2; -{ - long i; - long j; - long e; - - SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_right_x); - SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_right_x); - SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_right_x); - SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_right_x); - SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_right_x); - i = SCM_INUM (start1); - j = SCM_INUM (start2); - e = SCM_INUM (end1); - SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_right_x); - SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_right_x); - SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_right_x); - SCM_ASSERT ((j = e-i+j) <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_right_x); - while (i<e) SCM_VELTS (vec2)[--j] = SCM_VELTS (vec1)[--e]; - return SCM_UNSPECIFIED; -} - - - -void -scm_init_vectors () -{ -#include "vectors.x" -} - diff --git a/libguile/vectors.h b/libguile/vectors.h deleted file mode 100644 index 5b98afbcc..000000000 --- a/libguile/vectors.h +++ /dev/null @@ -1,73 +0,0 @@ -/* classes: h_files */ - -#ifndef VECTORSH -#define VECTORSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -#define SCM_VECTORP(x) (SCM_TYP7S(x)==scm_tc7_vector) -#define SCM_NVECTORP(x) (!SCM_VECTORP(x)) -#define SCM_VELTS(x) ((SCM *)SCM_CDR(x)) -#define SCM_SETVELTS SCM_SETCDR - - - -extern SCM scm_vector_p SCM_P ((SCM x)); -extern SCM scm_vector_length SCM_P ((SCM v)); -extern SCM scm_vector SCM_P ((SCM l)); -extern SCM scm_vector_ref SCM_P ((SCM v, SCM k)); -extern SCM scm_vector_set_x SCM_P ((SCM v, SCM k, SCM obj)); -extern SCM scm_make_vector SCM_P ((SCM k, SCM fill, SCM multi)); -extern SCM scm_vector_to_list SCM_P ((SCM v)); -extern SCM scm_vector_fill_x SCM_P ((SCM v, SCM fill_x)); -extern SCM scm_vector_equal_p SCM_P ((SCM x, SCM y)); -extern SCM scm_vector_move_left_x SCM_P ((SCM vec1, SCM start1, SCM end1, SCM - vec2, SCM start2)); -extern SCM scm_vector_move_right_x SCM_P ((SCM vec1, SCM start1, SCM end1, SCM - vec2, SCM start2)); -extern void scm_init_vectors SCM_P ((void)); - -#endif /* VECTORSH */ diff --git a/libguile/version.c b/libguile/version.c deleted file mode 100644 index 889b08efc..000000000 --- a/libguile/version.c +++ /dev/null @@ -1,85 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "_scm.h" - -#include "version.h" - - -/* Return a Scheme string containing Guile's major version number. */ - -SCM_PROC(s_major_version, "major-version", 0, 0, 0, scm_major_version); - -SCM -scm_major_version () -{ - return scm_makfrom0str (GUILE_MAJOR_VERSION); -} - -/* Return a Scheme string containing Guile's minor version number. */ - -SCM_PROC(s_minor_version, "minor-version", 0, 0, 0, scm_minor_version); - -SCM -scm_minor_version () -{ - return scm_makfrom0str (GUILE_MINOR_VERSION); -} - -/* Return a Scheme string containing Guile's complete version. */ - -SCM_PROC(s_version, "version", 0, 0, 0, scm_version); - -SCM -scm_version () -{ - return scm_makfrom0str (GUILE_VERSION); -} - - - - -void -scm_init_version () -{ -#include "version.x" -} diff --git a/libguile/version.h b/libguile/version.h deleted file mode 100644 index ff48cf231..000000000 --- a/libguile/version.h +++ /dev/null @@ -1,56 +0,0 @@ -/* classes: h_files */ - -#ifndef VERSIONH -#define VERSIONH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - -extern SCM scm_major_version SCM_P ((void)); -extern SCM scm_minor_version SCM_P ((void)); -extern SCM scm_version SCM_P ((void)); -extern void scm_init_version SCM_P ((void)); - -#endif /* VERSIONH */ diff --git a/libguile/vports.c b/libguile/vports.c deleted file mode 100644 index 89e398e98..000000000 --- a/libguile/vports.c +++ /dev/null @@ -1,226 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include <stdio.h> -#include "_scm.h" -#include "eval.h" -#include "chars.h" -#include "fports.h" - -#include "vports.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - - - -/* {Ports - soft ports} - * - */ - - - -static int prinsfpt SCM_P ((SCM exp, SCM port, scm_print_state *pstate)); - -static int -prinsfpt (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; -{ - scm_prinport (exp, port, "soft"); - return !0; -} - -/* sfputc sfwrite sfputs sfclose - * are called within a SCM_SYSCALL. - * - * So we need to set errno to 0 before returning. sfflush - * may be called within a SCM_SYSCALL. So we need to set errno to 0 - * before returning. - */ - - -static int sfputc SCM_P ((int c, SCM p)); - -static int -sfputc (c, p) - int c; - SCM p; -{ - scm_apply (SCM_VELTS (p)[0], SCM_MAKICHR (c), scm_listofnull); - errno = 0; - return c; -} - - -static scm_sizet sfwrite SCM_P ((char *str, scm_sizet siz, scm_sizet num, SCM p)); - -static scm_sizet -sfwrite (str, siz, num, p) - char *str; - scm_sizet siz; - scm_sizet num; - SCM p; -{ - SCM sstr; - sstr = scm_makfromstr (str, siz * num, 0); - scm_apply (SCM_VELTS (p)[1], sstr, scm_listofnull); - errno = 0; - return num; -} - - -static int sfputs SCM_P ((char *s, SCM p)); - -static int -sfputs (s, p) - char *s; - SCM p; -{ - sfwrite (s, 1, strlen (s), p); - return 0; -} - - -static int sfflush SCM_P ((SCM stream)); - -static int -sfflush (stream) - SCM stream; -{ - SCM f = SCM_VELTS (stream)[2]; - if (SCM_BOOL_F == f) - return 0; - f = scm_apply (f, SCM_EOL, SCM_EOL); - errno = 0; - return SCM_BOOL_F == f ? EOF : 0; -} - - -static int sfgetc SCM_P ((SCM p)); - -static int -sfgetc (p) - SCM p; -{ - SCM ans; - ans = scm_apply (SCM_VELTS (p)[3], SCM_EOL, SCM_EOL); - errno = 0; - if (SCM_FALSEP (ans) || SCM_EOF_VAL == ans) - return EOF; - SCM_ASSERT (SCM_ICHRP (ans), ans, SCM_ARG1, "getc"); - return SCM_ICHR (ans); -} - - -static int sfclose SCM_P ((SCM p)); - -static int -sfclose (p) - SCM p; -{ - SCM f = SCM_VELTS (p)[4]; - if (SCM_BOOL_F == f) - return 0; - f = scm_apply (f, SCM_EOL, SCM_EOL); - errno = 0; - return SCM_BOOL_F == f ? EOF : 0; -} - - - -SCM_PROC(s_make_soft_port, "make-soft-port", 2, 0, 0, scm_make_soft_port); - -SCM -scm_make_soft_port (pv, modes) - SCM pv; - SCM modes; -{ - struct scm_port_table * pt; - SCM z; - SCM_ASSERT (SCM_NIMP (pv) && SCM_VECTORP (pv) && 5 == SCM_LENGTH (pv), pv, SCM_ARG1, s_make_soft_port); - SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_make_soft_port); - SCM_NEWCELL (z); - SCM_DEFER_INTS; - pt = scm_add_to_port_table (z); - SCM_SETCAR (z, scm_tc16_sfport | scm_mode_bits (SCM_CHARS (modes))); - SCM_SETPTAB_ENTRY (z, pt); - SCM_SETSTREAM (z, pv); - SCM_ALLOW_INTS; - return z; -} - - -static int noop0 SCM_P ((SCM stream)); - -static int -noop0 (stream) - SCM stream; -{ - return 0; -} - - -scm_ptobfuns scm_sfptob = -{ - scm_markstream, - noop0, - prinsfpt, - 0, - sfputc, - sfputs, - sfwrite, - sfflush, - sfgetc, - sfclose -}; - - - -void -scm_init_vports () -{ -#include "vports.x" -} - diff --git a/libguile/vports.h b/libguile/vports.h deleted file mode 100644 index 27b14a3d6..000000000 --- a/libguile/vports.h +++ /dev/null @@ -1,59 +0,0 @@ -/* classes: h_files */ - -#ifndef VPORTSH -#define VPORTSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - -extern scm_ptobfuns scm_sfptob; - - - - - - -extern SCM scm_make_soft_port SCM_P ((SCM pv, SCM modes)); -extern void scm_init_vports SCM_P ((void)); - -#endif /* VPORTSH */ diff --git a/libguile/weaks.c b/libguile/weaks.c deleted file mode 100644 index cb2912970..000000000 --- a/libguile/weaks.c +++ /dev/null @@ -1,203 +0,0 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, Free Software Foundation gives permission - * for additional uses of the text contained in its release of this library. - * - * The exception is that, if you link this library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking this library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by - * Free Software Foundation as part of this library. If you copy - * code from other releases distributed under the terms of the GPL into a copy of - * this library, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from such code. - * - * If you write modifications of your own for this library, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - -#include <stdio.h> -#include "_scm.h" - -#include "weaks.h" - - - -/* {Weak Vectors} - */ - - -SCM_PROC(s_make_weak_vector, "make-weak-vector", 1, 1, 0, scm_make_weak_vector); - -SCM -scm_make_weak_vector (k, fill) - SCM k; - SCM fill; -{ - SCM v; - v = scm_make_vector (scm_sum (k, SCM_MAKINUM (1)), fill, SCM_UNDEFINED); - SCM_DEFER_INTS; - SCM_SETLENGTH(v, SCM_INUM (k), scm_tc7_wvect); - SCM_VELTS(v)[0] = (SCM)0; - SCM_SETVELTS(v, SCM_VELTS(v) + 1); - SCM_ALLOW_INTS; - return v; -} - - -SCM_PROC(s_weak_vector, "weak-vector", 0, 0, 1, scm_weak_vector); -SCM_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector); - -SCM -scm_weak_vector (l) - SCM l; -{ - SCM res; - register SCM *data; - long i; - - i = scm_ilength (l); - SCM_ASSERT (i >= 0, l, SCM_ARG1, s_weak_vector); - res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); - data = SCM_VELTS (res); - for (; - i && SCM_NIMP (l) && SCM_CONSP (l); - --i, l = SCM_CDR (l)) - *data++ = SCM_CAR (l); - return res; -} - - -SCM_PROC(s_weak_vector_p, "weak-vector?", 1, 0, 0, scm_weak_vector_p); - -SCM -scm_weak_vector_p (x) - SCM x; -{ - return ((SCM_NIMP (x) && SCM_WVECTP (x) && !SCM_IS_WHVEC (x)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - - - - - -SCM_PROC(s_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, scm_make_weak_key_hash_table); - -SCM -scm_make_weak_key_hash_table (k) - SCM k; -{ - SCM v; - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_key_hash_table); - v = scm_make_weak_vector (k, SCM_EOL); - SCM_ALLOW_INTS; - SCM_VELTS (v)[-1] = 1; - SCM_ALLOW_INTS; - return v; -} - - -SCM_PROC (s_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0, scm_make_weak_value_hash_table); - -SCM -scm_make_weak_value_hash_table (k) - SCM k; -{ - SCM v; - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_value_hash_table); - v = scm_make_weak_vector (k, SCM_EOL); - SCM_ALLOW_INTS; - SCM_VELTS (v)[-1] = 2; - SCM_ALLOW_INTS; - return v; -} - - - -SCM_PROC (s_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, scm_make_doubly_weak_hash_table); - -SCM -scm_make_doubly_weak_hash_table (k) - SCM k; -{ - SCM v; - SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_doubly_weak_hash_table); - v = scm_make_weak_vector (k, SCM_EOL); - SCM_ALLOW_INTS; - SCM_VELTS (v)[-1] = 3; - SCM_ALLOW_INTS; - return v; -} - -SCM_PROC(s_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, scm_weak_key_hash_table_p); - -SCM -scm_weak_key_hash_table_p (x) - SCM x; -{ - return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC(x)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC (s_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, scm_weak_value_hash_table_p); - -SCM -scm_weak_value_hash_table_p (x) - SCM x; -{ - return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_V(x)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - -SCM_PROC (s_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, scm_doubly_weak_hash_table_p); - -SCM -scm_doubly_weak_hash_table_p (x) - SCM x; -{ - return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_B (x)) - ? SCM_BOOL_T - : SCM_BOOL_F); -} - - - - - -void -scm_init_weaks () -{ -#include "weaks.x" -} - diff --git a/libguile/weaks.h b/libguile/weaks.h deleted file mode 100644 index 8a6eb467d..000000000 --- a/libguile/weaks.h +++ /dev/null @@ -1,71 +0,0 @@ -/* classes: h_files */ - -#ifndef WEAKSH -#define WEAKSH -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. - */ - - -#include "libguile/__scm.h" - - - - -#define SCM_WVECTP(x) (SCM_TYP7(x)==scm_tc7_wvect) -#define SCM_IS_WHVEC(X) (SCM_VELTS(X)[-1] == 1) -#define SCM_IS_WHVEC_V(X) (SCM_VELTS(X)[-1] == 2) -#define SCM_IS_WHVEC_B(X) (SCM_VELTS(X)[-1] == 3) -#define SCM_IS_WHVEC_ANY(X) (SCM_VELTS(X)[-1]) - - - -extern SCM scm_make_weak_vector SCM_P ((SCM k, SCM fill)); -extern SCM scm_weak_vector SCM_P ((SCM l)); -extern SCM scm_weak_vector_p SCM_P ((SCM x)); -extern SCM scm_make_weak_key_hash_table SCM_P ((SCM k)); -extern SCM scm_make_weak_value_hash_table SCM_P ((SCM k)); -extern SCM scm_make_doubly_weak_hash_table SCM_P ((SCM k)); -extern SCM scm_weak_key_hash_table_p SCM_P ((SCM x)); -extern SCM scm_weak_value_hash_table_p SCM_P ((SCM x)); -extern SCM scm_doubly_weak_hash_table_p SCM_P ((SCM x)); -extern void scm_init_weaks SCM_P ((void)); - -#endif /* WEAKSH */ diff --git a/mdate-sh b/mdate-sh deleted file mode 100755 index 0845b8bc8..000000000 --- a/mdate-sh +++ /dev/null @@ -1,91 +0,0 @@ -#!/bin/sh -# mdate-sh - get modification time of a file and pretty-print it -# Copyright (C) 1995 Software Foundation, Inc. -# Written by Ulrich Drepper <drepper@gnu.ai.mit.edu>, June 1995 -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; either version 2, or (at your option) -# any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -# Prevent date giving response in another language. -LANG=C -export LANG -LC_ALL=C -export LC_ALL -LC_TIME=C -export LC_TIME - -# Get the extended ls output of the file. -if ls -L /dev/null 1>/dev/null 2>&1; then - set - `ls -L -l $1` -else - set - `ls -l $1` -fi -# The month is at least the fourth argument. -# (3 shifts here, the next inside the loop) -shift -shift -shift - -# Find the month. Next argument is day, followed by the year or time. -month= -until test $month -do - shift - case $1 in - Jan) month=January; nummonth=1;; - Feb) month=February; nummonth=2;; - Mar) month=March; nummonth=3;; - Apr) month=April; nummonth=4;; - May) month=May; nummonth=5;; - Jun) month=June; nummonth=6;; - Jul) month=July; nummonth=7;; - Aug) month=August; nummonth=8;; - Sep) month=September; nummonth=9;; - Oct) month=October; nummonth=10;; - Nov) month=November; nummonth=11;; - Dec) month=December; nummonth=12;; - esac -done - -day=$2 - -# Here we have to deal with the problem that the ls output gives either -# the time of day or the year. -case $3 in - *:*) set `date`; eval year=\$$# - case $2 in - Jan) nummonthtod=1;; - Feb) nummonthtod=2;; - Mar) nummonthtod=3;; - Apr) nummonthtod=4;; - May) nummonthtod=5;; - Jun) nummonthtod=6;; - Jul) nummonthtod=7;; - Aug) nummonthtod=8;; - Sep) nummonthtod=9;; - Oct) nummonthtod=10;; - Nov) nummonthtod=11;; - Dec) nummonthtod=12;; - esac - # For the first six month of the year the time notation can also - # be used for files modified in the last year. - if (expr $nummonth \> $nummonthtod) > /dev/null; - then - year=`expr $year - 1` - fi;; - *) year=$3;; -esac - -# The result. -echo $day $month $year diff --git a/mkinstalldirs b/mkinstalldirs deleted file mode 100755 index cc8783edc..000000000 --- a/mkinstalldirs +++ /dev/null @@ -1,36 +0,0 @@ -#! /bin/sh -# mkinstalldirs --- make directory hierarchy -# Author: Noah Friedman <friedman@prep.ai.mit.edu> -# Created: 1993-05-16 -# Last modified: 1994-03-25 -# Public domain - -errstatus=0 - -for file in ${1+"$@"} ; do - set fnord `echo ":$file" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'` - shift - - pathcomp= - for d in ${1+"$@"} ; do - pathcomp="$pathcomp$d" - case "$pathcomp" in - -* ) pathcomp=./$pathcomp ;; - esac - - if test ! -d "$pathcomp"; then - echo "mkdir $pathcomp" 1>&2 - mkdir "$pathcomp" > /dev/null 2>&1 || lasterr=$? - fi - - if test ! -d "$pathcomp"; then - errstatus=$lasterr - fi - - pathcomp="$pathcomp/" - done -done - -exit $errstatus - -# mkinstalldirs ends here diff --git a/qt/.cvsignore b/qt/.cvsignore deleted file mode 100644 index 6a401c3ff..000000000 --- a/qt/.cvsignore +++ /dev/null @@ -1,5 +0,0 @@ -Makefile -config.log -config.status -qt.h -.deps diff --git a/qt/CHANGES b/qt/CHANGES deleted file mode 100644 index 1b74921ee..000000000 --- a/qt/CHANGES +++ /dev/null @@ -1,15 +0,0 @@ -QuickThreads 002: Changes since QuickThreads 001. - - - Now can be used by C++ programs. - - Now *really* works with stacks that grow up. - - Supports AXP OSF 2.x cc's varargs. - - Supports HP Precision (HP-PA) on workstations and Convex. - - Supports assemblers for Intel iX86 ith only '//'-style comments. - - Supports Silicon Graphics Irix 5.x with dynamic linking. - - Supports System V and Solaris 2.x with no `_' on compiler-generated - identifiers; *some* platforms only. - -Note: not all "./config" arguments are compatible with QT 001. - - -QuickThreads 001: Base version. diff --git a/qt/ChangeLog b/qt/ChangeLog deleted file mode 100644 index 869a97e87..000000000 --- a/qt/ChangeLog +++ /dev/null @@ -1,53 +0,0 @@ -Mon Dec 9 17:55:59 1996 Jim Blandy <jimb@duality.gnu.ai.mit.edu> - - We need to name the object files produced from the - machine-dependent C and assembler files qtmds.o and qtmdc.o, but - using -c and -o together on the cc command line isn't portable. - * configure.in: Generate the names of the .o files here, and - substitute them into Makefile. - * Makefile.am (qtmds.o, qtmdc.o): Let CC name them what it wants, - and then rename them when it's done. - (configure, Makefile.in): Regenerated. - -Sat Nov 30 23:59:06 1996 Tom Tromey <tromey@cygnus.com> - - * PLUGIN/greet: Removed. - * Makefile.am, md/Makefile.am, time/Makefile.am, aclocal.m4: New - files. - * configure.in: Updated for Automake. - -Sun Nov 10 17:40:47 1996 Jim Blandy <jimb@floss.cyclic.com> - - * configure.in, Makefile.in: The 'install' and 'uninstall' - Makefile targets should be affected by whether or not we have a - port to the current target architecture too, not just the 'all' - target. - -Wed Oct 9 19:40:13 1996 Jim Blandy <jimb@floss.cyclic.com> - - * configure.in: If we don't have a port to the current machine, - just arrange for 'make all' to do nothing. Don't abort - configuration. We need a fully configured directory tree in order - to make distributions and the like. - - * Makefile.in (distfiles): Update for the new directory structure. - (plugin_distfiles, md_distfiles, time_distfiles): New variables. - (dist-dir): New target; use all the above to build a subtree of a - distribution. - (manifest): Target deleted. - -Tue Oct 1 02:06:19 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se> - - * configure.in: Solaris 2 should use sparc.s. - *Older* systems use _sparc.s - -Fri Mar 29 11:50:20 1996 Anthony Green <green@snuffle.cygnus.com> - - * configure: Rebuilt - * Makefile.in, configure.in: Fixed installation. - -Fri Mar 22 16:20:27 1996 Anthony Green (green@gerbil.cygnus.com) - - * all files: installed qt-002 package. Autoconfiscated. - - diff --git a/qt/INSTALL b/qt/INSTALL deleted file mode 100644 index 5b20f5d5e..000000000 --- a/qt/INSTALL +++ /dev/null @@ -1,81 +0,0 @@ -Installation of the `QuickThreads' threads-building toolkit. - -* Notice - -QuickThreads -- Threads-building toolkit. -Copyright (c) 1993 by David Keppel - -Permission to use, copy, modify and distribute this software and -its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice and this notice -appear in all copies. This software is provided as a -proof-of-concept and for demonstration purposes; there is no -representation about the suitability of this software for any -purpose. - - -* Configuration - -Configure with - - ./config *machtype* - -where "*machtype*" is one of the supported target machines. As of -October 1994, the supported machines (targets) are: - - axp -- All Digital Equipment Corporation AXP (DEC Alpha) - processors, compile with GNU CC - axp-osf1 -- AXP running OSF 1.x - axp-osf2 -- AXP running OSF 2.x - hppa -- HP's PA-RISC 1.1 processor - hppa-cnx-spp -- Convex SPP (PA-RISC 1.1 processor) - iX86 -- 80386, 80486, and 80586-compatible processors - See notes below for OS/2. - iX86-ss -- 'iX86 for assemblers that use slash-slash ('//') - comments. - ksr1 -- All KSR processors - m88k -- All members of the Motorola 88000 family - mips -- MIPS R2000 and R3000 processors - mips-irix5 -- Irix 5.xx (use `mips' for Irix 4.xx) - sparc-os1 -- V8-compliant SPARC processors using compilers - that prefix labels (e.g. "foo" appears as "_foo") - Includes Solaris 1 (SunOS 4.X). - sparc-os2 -- V8-compliant SPARC processors using compilers - that do not prefix labels. Includes Solaris 2. - vax -- All VAX processors - -In addition, the target `clean' will deconfigure QuickThreads. - -Note that a given machine target may not work on all instances of that -machine because e.g., the assembler syntax varies from machine to -machine. - -Note also that additions to a processor family may require a new -target. So, for example, the `vax' target might not work for all -future VAX processors if, say, new VAX processors are introduced and -they use separate floating-point registers. - -For OS/2, change `ranlib' to `ar -s', `configure' to `configure.cmd' -(or was that `config' to `config.cmd'?), and replace the soft links -(`ln -s') with plain copies. - - -* Build - -To build the QuickThreads library, first configure (see above) then -type `make libqt.a' in the top-level directory. - -To build the demonstration threads package, SimpleThreads, type -`make libstp.a' in the top-level directory. - -To build an executable ``stress-test'' and measurement program, type -`make run' in the top-level directory. Run `time/raw' to run the -stress tests. - - -* Installation - -Build the QuickThreads library (see above) and then copy `libqt.a' to -the installation library directory (e.g., /usr/local/lib) and `qt.h' -and `qtmd.h' to the installation include directory (e.g., -/usr/local/include). diff --git a/qt/Makefile.am b/qt/Makefile.am deleted file mode 100644 index 7b4269477..000000000 --- a/qt/Makefile.am +++ /dev/null @@ -1,23 +0,0 @@ -## Process this file with automake to produce Makefile.in. - -AUTOMAKE_OPTIONS = foreign - -## subdirs are for making distributions only. -SUBDIRS = md time - -lib_LIBRARIES = @target_libs@ -EXTRA_LIBRARIES = libqt.a - -libqt_a_SOURCES = qt.c copyright.h -libqt_a_LIBADD = qtmds.o qtmdc.o - -qtmds.o: @qtmds_s@ - $(COMPILE) -c @qtmds_s@ - mv @qtmds_o@ qtmds.o - -qtmdc.o: @qtmdc_c@ @qtmd_h@ - $(COMPILE) -c @qtmdc_c@ - mv @qtmdc_o@ qtmdc.o - -EXTRA_DIST = CHANGES README.MISC README.PORT b.h meas.c stp.c stp.h \ -PLUGIN/OPT Makefile.base config diff --git a/qt/Makefile.base b/qt/Makefile.base deleted file mode 100644 index 73a082f50..000000000 --- a/qt/Makefile.base +++ /dev/null @@ -1,112 +0,0 @@ -.SUFFIXES: .c .o .s .E - -# -# Need to include from the current directory because "qt.h" -# will include <qtmd.h>. -# -CFLAGS = -I. -g - -# -# Fix this to be something meaningful for your system. -# -DEST = /dev/null - -DOC = users.tout - -EXTHDRS = /usr/include/stdio.h - -HDRS = qt.h \ - qtmd.h \ - stp.h - -LDFLAGS = $(CFLAGS) - -EXTLIBS = - -LIBS = libstp.a libqt.a - -LINKER = $(CC) - -MAKEFILE = Makefile - -M = Makefile configuration - -OBJS = qtmdb.o \ - meas.o - -QTOBJS = qt.o qtmds.o qtmdc.o - -STPOBJS = stp.o - -PR = -Pps - -PRINT = pr - -PROGRAM = run - -SRCS = meas.c \ - qt.c \ - qtmdc.c \ - qtmds.s \ - qtmdb.s - -TMP_INIT = tmp.init -TMP_SWAP = tmp.swap - -.DEFAULT: - co -q $@ - -.c.E: force - $(CC) $(CFLAGS) -E $*.c > $*.E - -all: libqt.a libstp.a $(PROGRAM) $(M) - -libqt.a: $(QTOBJS) $(M) - ar crv libqt.a $(QTOBJS) - ranlib libqt.a - -libstp.a: $(STPOBJS) $(M) - ar crv libstp.a $(STPOBJS) - ranlib libstp.a - -$(PROGRAM): $(OBJS) $(LIBS) $(M) - @echo "Loading $(PROGRAM) ... " -# ld -o $(PROGRAM) /lib/crt0.o $(OBJS) -lc - $(LINKER) $(LDFLAGS) $(OBJS) $(LIBS) $(EXTLIBS) -o $(PROGRAM) - @echo "done" - -clean: - rm -f $(OBJS) $(PROGRAM) $(TMP_INIT) $(TMP_SWAP) $(DOC) - rm -f libqt.a libstp.a - rm -f $(QTOBJS) $(STPOBJS) - -depend:; @mkmf -f $(MAKEFILE) PROGRAM=$(PROGRAM) DEST=$(DEST) - -doc: users.ms raw - time/assim < raw | grep "^init" | sed 's/^init //' > $(TMP_INIT) - time/assim < raw | grep "^swap" | sed 's/^swap //' > $(TMP_SWAP) - soelim users.ms | tbl $(PR) | troff -t $(PR) -ms > $(DOC) - -index:; @ctags -wx $(HDRS) $(SRCS) - -print:; @$(PRINT) $(HDRS) $(SRCS) - -program: $(PROGRAM) - -tags: $(HDRS) $(SRCS); @ctags $(HDRS) $(SRCS) - -update: $(DEST)/$(PROGRAM) - -$(DEST)/$(PROGRAM): $(SRCS) $(LIBS) $(HDRS) $(EXTHDRS) - @make -f $(MAKEFILE) DEST=$(DEST) install - -QT_H = qt.h $(QTMD_H) -QTMD_H = qtmd.h - -### -qtmdb.o: $(M) qtmdb.s b.h -meas.o: $(M) meas.c /usr/include/stdio.h $(QT_H) b.h stp.h -qt.o: $(M) qt.c $(QT_H) -stp.o: $(M) stp.c stp.h $(QT_H) -qtmds.o: $(M) qtmds.s -qtmdc.o: $(M) qtmdc.c $(QT_H) diff --git a/qt/Makefile.in b/qt/Makefile.in deleted file mode 100644 index f5ecb23cc..000000000 --- a/qt/Makefile.in +++ /dev/null @@ -1,388 +0,0 @@ -# Makefile.in generated automatically by automake 1.1l from Makefile.am - -# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. -# This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - - -SHELL = /bin/sh - -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -VPATH = @srcdir@ -prefix = @prefix@ -exec_prefix = @exec_prefix@ - -bindir = @bindir@ -sbindir = @sbindir@ -libexecdir = @libexecdir@ -datadir = @datadir@ -sysconfdir = @sysconfdir@ -sharedstatedir = @sharedstatedir@ -localstatedir = @localstatedir@ -libdir = @libdir@ -infodir = @infodir@ -mandir = @mandir@ -includedir = @includedir@ -oldincludedir = /usr/include - -pkgdatadir = $(datadir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ - -top_builddir = . - -INSTALL = @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -transform = @program_transform_name@ -host_alias = @host_alias@ -host_triplet = @host@ -RANLIB = @RANLIB@ -module = @module@ -qtmd_h = @qtmd_h@ -CC = @CC@ -PACKAGE = @PACKAGE@ -VERSION = @VERSION@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -qtmds_o = @qtmds_o@ -qtmdc_o = @qtmdc_o@ -target_libs = @target_libs@ -qtmds_s = @qtmds_s@ -qtmdc_c = @qtmdc_c@ -qtmdb_s = @qtmdb_s@ - -AUTOMAKE_OPTIONS = foreign - -SUBDIRS = md time - -lib_LIBRARIES = @target_libs@ -EXTRA_LIBRARIES = libqt.a - -libqt_a_SOURCES = qt.c copyright.h -libqt_a_LIBADD = qtmds.o qtmdc.o - -EXTRA_DIST = CHANGES README.MISC README.PORT b.h meas.c stp.c stp.h \ -PLUGIN/OPT Makefile.base config -ACLOCAL = $(top_srcdir)/aclocal.m4 -mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs -CONFIG_CLEAN_FILES = qt.h -LIBRARIES = $(lib_LIBRARIES) - - -DEFS = @DEFS@ -I. -I$(srcdir) -CPPFLAGS = @CPPFLAGS@ -LDFLAGS = @LDFLAGS@ -LIBS = @LIBS@ -libqt_a_DEPENDENCIES = qtmds.o qtmdc.o -libqt_a_OBJECTS = qt.o -AR = ar -CFLAGS = @CFLAGS@ -COMPILE = $(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) -LINK = $(CC) $(LDFLAGS) -o $@ -DIST_COMMON = README ChangeLog INSTALL Makefile.am Makefile.in README \ -aclocal.m4 configure configure.in qt.h.in - - -DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \ - $(TEXINFOS) $(MANS) $(EXTRA_DIST) - -TAR = tar -DEP_FILES = .deps/qt.P -SOURCES = $(libqt_a_SOURCES) -OBJECTS = $(libqt_a_OBJECTS) - -default: all - -.SUFFIXES: -.SUFFIXES: .c .o -$(srcdir)/Makefile.in: Makefile.am $(top_srcdir)/configure.in $(ACLOCAL) - cd $(top_srcdir) && automake --foreign Makefile - -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES) - cd $(top_builddir) \ - && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status - -$(srcdir)/aclocal.m4: configure.in - cd $(srcdir) && aclocal - -config.status: configure - $(SHELL) ./config.status --recheck -$(srcdir)/configure: configure.in $(ACLOCAL) $(CONFIGURE_DEPENDENCIES) - cd $(srcdir) && autoconf -qt.h: $(top_builddir)/config.status qt.h.in - cd $(top_builddir) && CONFIG_FILES=$@ CONFIG_HEADERS= ./config.status - -mostlyclean-libLIBRARIES: - -clean-libLIBRARIES: - test -z "$(lib_LIBRARIES)" || rm -f $(lib_LIBRARIES) - -distclean-libLIBRARIES: - -maintainer-clean-libLIBRARIES: - -install-libLIBRARIES: $(lib_LIBRARIES) - $(NORMAL_INSTALL) - $(mkinstalldirs) $(libdir) - list="$(lib_LIBRARIES)"; for p in $$list; do \ - if test -f $$p; then \ - echo "$(INSTALL_DATA) $$p $(libdir)/$$p"; \ - $(INSTALL_DATA) $$p $(libdir)/$$p; \ - else :; fi; \ - done - $(POST_INSTALL) - @list="$(lib_LIBRARIES)"; for p in $$list; do \ - if test -f $$p; then \ - echo "$(RANLIB) $(libdir)/$$p"; \ - $(RANLIB) $(libdir)/$$p; \ - else :; fi; \ - done - -uninstall-libLIBRARIES: - list="$(lib_LIBRARIES)"; for p in $$list; do \ - rm -f $(libdir)/$$p; \ - done - -.c.o: - $(COMPILE) -c $< - -mostlyclean-compile: - rm -f *.o core - -clean-compile: - -distclean-compile: - rm -f *.tab.c - -maintainer-clean-compile: - -libqt.a: $(libqt_a_OBJECTS) $(libqt_a_DEPENDENCIES) - rm -f libqt.a - $(AR) cru libqt.a $(libqt_a_OBJECTS) $(libqt_a_LIBADD) - $(RANLIB) libqt.a - -# This directory's subdirectories are mostly independent; you can cd -# into them and run `make' without going through this Makefile. -# To change the values of `make' variables: instead of editing Makefiles, -# (1) if the variable is set in `config.status', edit `config.status' -# (which will cause the Makefiles to be regenerated when you run `make'); -# (2) otherwise, pass the desired values on the `make' command line. - -@SET_MAKE@ - -all-recursive install-data-recursive install-exec-recursive \ -installdirs-recursive install-recursive uninstall-recursive \ -check-recursive installcheck-recursive info-recursive dvi-recursive \ -mostlyclean-recursive clean-recursive distclean-recursive \ -maintainer-clean-recursive: - @for subdir in $(SUBDIRS); do \ - target=`echo $@ | sed s/-recursive//`; \ - echo "Making $$target in $$subdir"; \ - (cd $$subdir && $(MAKE) $$target) \ - || case "$(MFLAGS)" in *k*) fail=yes;; *) exit 1;; esac; \ - done && test -z "$$fail" -tags-recursive: - list="$(SUBDIRS)"; for subdir in $$list; do \ - (cd $$subdir && $(MAKE) tags); \ - done - -tags: TAGS - -ID: $(HEADERS) $(SOURCES) - here=`pwd` && cd $(srcdir) && mkid -f$$here/ID $(SOURCES) $(HEADERS) - -TAGS: tags-recursive $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) - tags=; \ - here=`pwd`; \ - list="$(SUBDIRS)"; for subdir in $$list; do \ - test -f $$subdir/TAGS && tags="$$tags -i $$here/$$subdir/TAGS"; \ - done; \ - test -z "$(ETAGS_ARGS)$(SOURCES)$(HEADERS)$$tags" \ - || cd $(srcdir) && etags $(ETAGS_ARGS) $$tags $(SOURCES) $(HEADERS) -o $$here/TAGS - -mostlyclean-tags: - -clean-tags: - -distclean-tags: - rm -f TAGS ID - -maintainer-clean-tags: - -distdir = $(PACKAGE)-$(VERSION) -# This target untars the dist file and tries a VPATH configuration. Then -# it guarantees that the distribution is self-contained by making another -# tarfile. -distcheck: dist - rm -rf $(distdir) - $(TAR) zxf $(distdir).tar.gz - mkdir $(distdir)/=build - mkdir $(distdir)/=inst - dc_install_base=`cd $(distdir)/=inst && pwd`; \ - cd $(distdir)/=build \ - && ../configure --srcdir=.. --prefix=$$dc_install_base \ - && $(MAKE) \ - && $(MAKE) dvi \ - && $(MAKE) check \ - && $(MAKE) install \ - && $(MAKE) installcheck \ - && $(MAKE) dist - rm -rf $(distdir) - @echo "========================"; \ - echo "$(distdir).tar.gz is ready for distribution"; \ - echo "========================" -dist: distdir - -chmod -R a+r $(distdir) - $(TAR) chozf $(distdir).tar.gz $(distdir) - rm -rf $(distdir) -dist-all: distdir - -chmod -R a+r $(distdir) - $(TAR) chozf $(distdir).tar.gz $(distdir) - rm -rf $(distdir) -distdir: $(DISTFILES) - rm -rf $(distdir) - mkdir $(distdir) - -chmod 755 $(distdir) - here=`pwd`; distdir=`cd $(distdir) && pwd` \ - && cd $(srcdir) \ - && automake --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --foreign - $(mkinstalldirs) $(distdir)/PLUGIN - @for file in $(DISTFILES); do \ - d=$(srcdir); \ - test -f $(distdir)/$$file \ - || ln $$d/$$file $(distdir)/$$file 2> /dev/null \ - || cp -p $$d/$$file $(distdir)/$$file; \ - done - for subdir in $(SUBDIRS); do \ - test -d $(distdir)/$$subdir \ - || mkdir $(distdir)/$$subdir \ - || exit 1; \ - chmod 755 $(distdir)/$$subdir; \ - (cd $$subdir && $(MAKE) distdir=../$(distdir)/$$subdir distdir) \ - || exit 1; \ - done - -MKDEP = gcc -M $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) - --include .deps/.P -.deps/.P: - test -d .deps || mkdir .deps - echo > $@ - --include $(DEP_FILES) -$(DEP_FILES): .deps/.P - -mostlyclean-depend: - -clean-depend: - -distclean-depend: - -maintainer-clean-depend: - rm -rf .deps - -.deps/%.P: $(srcdir)/%.c - @echo "Computing dependencies for $<..." - @o='o'; \ - test -n "$o" && o='$$o'; \ - $(MKDEP) $< | sed "s/^\(.*\)\.o:/\1.$$o \1.l$$o:/" > $@ -info: info-recursive -dvi: dvi-recursive -check: all-am - $(MAKE) check-recursive -installcheck: installcheck-recursive -all-am: $(LIBRARIES) Makefile - -install-exec-am: install-libLIBRARIES - -uninstall-am: uninstall-libLIBRARIES - -install-exec: install-exec-recursive install-exec-am - $(NORMAL_INSTALL) - -install-data: install-data-recursive - $(NORMAL_INSTALL) - -install: install-recursive install-exec-am - @: - -uninstall: uninstall-recursive uninstall-am - -all: all-recursive all-am - -install-strip: - $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install -installdirs: installdirs-recursive - $(mkinstalldirs) $(libdir) - - -mostlyclean-generic: - test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) - -clean-generic: - test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) - -distclean-generic: - rm -f Makefile $(DISTCLEANFILES) - rm -f config.cache config.log stamp-h - test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -maintainer-clean-generic: - test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) - test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) -mostlyclean-am: mostlyclean-libLIBRARIES mostlyclean-compile \ - mostlyclean-tags mostlyclean-depend mostlyclean-generic - -clean-am: clean-libLIBRARIES clean-compile clean-tags clean-depend \ - clean-generic mostlyclean-am - -distclean-am: distclean-libLIBRARIES distclean-compile distclean-tags \ - distclean-depend distclean-generic clean-am - -maintainer-clean-am: maintainer-clean-libLIBRARIES \ - maintainer-clean-compile maintainer-clean-tags \ - maintainer-clean-depend maintainer-clean-generic \ - distclean-am - -mostlyclean: mostlyclean-am mostlyclean-recursive - -clean: clean-am clean-recursive - -distclean: distclean-am distclean-recursive - rm -f config.status - -maintainer-clean: maintainer-clean-am maintainer-clean-recursive - @echo "This command is intended for maintainers to use;" - @echo "it deletes files that may require special tools to rebuild." - rm -f config.status - -.PHONY: default mostlyclean-libLIBRARIES distclean-libLIBRARIES \ -clean-libLIBRARIES maintainer-clean-libLIBRARIES uninstall-libLIBRARIES \ -install-libLIBRARIES mostlyclean-compile distclean-compile \ -clean-compile maintainer-clean-compile install-data-recursive \ -uninstall-data-recursive install-exec-recursive \ -uninstall-exec-recursive installdirs-recursive uninstalldirs-recursive \ -all-recursive check-recursive installcheck-recursive info-recursive \ -dvi-recursive mostlyclean-recursive distclean-recursive clean-recursive \ -maintainer-clean-recursive tags tags-recursive mostlyclean-tags \ -distclean-tags clean-tags maintainer-clean-tags distdir \ -mostlyclean-depend distclean-depend clean-depend \ -maintainer-clean-depend info dvi installcheck all-am install-exec-am \ -uninstall-am install-exec install-data install uninstall all \ -installdirs mostlyclean-generic distclean-generic clean-generic \ -maintainer-clean-generic clean mostlyclean distclean maintainer-clean - - -qtmds.o: @qtmds_s@ - $(COMPILE) -c @qtmds_s@ - mv @qtmds_o@ qtmds.o - -qtmdc.o: @qtmdc_c@ @qtmd_h@ - $(COMPILE) -c @qtmdc_c@ - mv @qtmdc_o@ qtmdc.o - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff --git a/qt/README b/qt/README deleted file mode 100644 index b014b91bf..000000000 --- a/qt/README +++ /dev/null @@ -1,89 +0,0 @@ -This is a source code distribution for QuickThreads. QuickThreads is a -toolkit for building threads packages; it is described in detail in the -University of Washington CS&E Technical report #93-05-06, available via -anonymous ftp from `ftp.cs.washington.edu' (128.95.1.4, as of Oct. '94) -in `tr/1993/05/UW-CSE-93-05-06.PS.Z'. - -This distribution shows basic ideas in QuickThreads and elaborates with -example implementations for a gaggle of machines. As of October those -machines included: - - 80386 faimly - 88000 faimily - DEC AXP (Alpha) family - HP-PA family - KSR - MIPS family - SPARC V8 family - VAX family - -Configuration, build, and installation are described in INSTALL. - -Be aware: that there is no varargs code for the KSR. - -The HP-PA port was designed to work with both HP workstations -and Convex SPP computers. It was generously provided by Uwe Reder -<uereder@cip.informatik.uni-erlangen.de>. It is part of the ELiTE -(Erlangen Lightweight Thread Environment) project directed by -Frank Bellosa <bellosa@informatik.uni-erlangen.de> at the Operating -Systems Department of the University of Erlangen (Germany). - -Other contributors include: Weihaw Chuang, Richard O'Keefe, -Laurent Perron, John Polstra, Shinji Suzuki, Assar Westerlund, -thanks also to Peter Buhr and Dirk Grunwald. - - -Here is a brief summary: - -QuickThreads is a toolkit for building threads packages. It is my hope -that you'll find it easier to use QuickThreads normally than to take it -and modify the raw cswap code to fit your application. The idea behind -QuickThreads is that it should make it easy for you to write & retarget -threads packages. If you want the routine `t_create' to create threads -and `t_block' to suspend threads, you write them using the QuickThreads -`primitive' operations `QT_SP', `QT_INIT', and `QT_BLOCK', that perform -machine-dependent initialization and blocking, plus code you supply for -performing the portable operatons. For example, you might write: - - t_create (func, arg) - { - stk = malloc (STKSIZE); - stackbase = QT_SP (stk, STKSIZE); - sp = QT_INIT (stakcbase, func, arg); - qput (runq, sp); - } - -Threads block by doing something like: - - t_block() - { - sp_next = qget (runq); - QT_BLOCK (helper, runq, sp_next); - // wake up again here - } - - // called by QT_BLOCK after the old thread has blocked, - // puts the old thread on the queue `onq'. - helper (sp_old, onq) - { - qput (onq, sp_old); - } - -(Of course) it's actually a bit more complex than that, but the general -idea is that you write portable code to allocate stacks and enqueue and -dequeue threads. Than, to get your threads package up and running on a -different machine, you just reconfigure QuickThreads and recompile, and -that's it. - -The QuickThreads `distribution' includes a sample threads package (look -at stp.{c,h}) that is written in terms of QuickThreads operations. The -TR mentioned above explains the simple threads package in detail. - - - -If you do use QuickThreads, I'd like to hear both about what worked for -you and what didn't work, problems you had, insights gleaned, etc. - -Let me know what you think. - -David Keppel <pardo@cs.washington.edu> diff --git a/qt/README.MISC b/qt/README.MISC deleted file mode 100644 index d10e487cf..000000000 --- a/qt/README.MISC +++ /dev/null @@ -1,56 +0,0 @@ -Here's some machine-specific informatin for various systems: - -m88k on g88.sim - - .g88init: - echo (gdb) target sim\n - target sim - echo (gdb) ecatch all\n - ecatch all - echo (gdb) break exit\n - break exit - % vi Makefile // set CC and AS - % setenv MEERKAT /projects/cer/meerkat - % set path=($MEERKAT/bin $path) - % make run - % g88.sim run - (g88) run run N // where `N' is the test number - - -m88k on meerkats, cross compile as above (make run) - - Run w/ g88: - %g88 run - (g88) source /homes/rivers/robertb/.gdbinit - (g88) me - which does - (g88) set $firstchars=6 - (g88) set $resetonattach=1 - (g88) attach /dev/pp0 - then download - (g88) dl - and run with - (g88) continue - - Really the way to run it is: - (g88) source - (g88) me - (g88) win - (g88) dead 1 - (g88) dead 2 - (g88) dead 3 - (g88) dl - (g88) cont - - To rerun - (g88) init - (g88) dl - - To run simulated meerkat: - (g88) att sim - <<then use normal commands>> - - On 4.5 g88: - (g88) target sim memsize - instead of attatch - (g88) ecatch all # catch exception before becomes error diff --git a/qt/README.PORT b/qt/README.PORT deleted file mode 100644 index d56300923..000000000 --- a/qt/README.PORT +++ /dev/null @@ -1,112 +0,0 @@ -Date: Tue, 11 Jan 94 13:23:11 -0800 -From: "pardo@cs.washington.edu" <pardo@meitner.cs.washington.edu> - ->[What's needed to get `qt' on an i860-based machine?] - -Almost certainly "some assembly required" (pun accepted). - -To write a cswap port, you need to understand the context switching -model. Turn to figure 2 in the QT TR. Here's about what the assembly -code looks like to implement that: - - qt_cswap: - adjust stack pointer - save callee-save registers on to old's stack - argument register <- old sp - sp <- new sp - (*helper)(args...) - restore callee-save registers from new's stack - unadjust stack pointer - return - -Once more in slow motion: - - - `old' thread calls context switch routine (new, a0, a1, h) - - cswap routine saves registers that have useful values - - cswap routine switches to new stack - - cswap routine calls helper function (*h)(old, a0, a1) - - when helper returns, cswap routine restores registers - that were saved the last time `new' was suspended - - cswap routine returns to whatever `new' routine called the - context switch routine - -There's a few tricks here. First, how do you start a thread running -for the very first time? Answer is: fake some stuff on the stack -so it *looks* like it was called from the middle of some routine. -When the new thread is restarted, it is treated like any other -thread. It just so happens that it's never really run before, but -you can't tell that because the saved state makes it look like like -it's been run. The return pc is set to point at a little stub of -assembly code that loads up registers with the right values and -then calls `only'. - -Second, I advise you to forget about varargs routines (at least -until you get single-arg routines up and running). - -Third, on most machines `qt_abort' is the same as `qt_cswap' except -that it need not save any callee-save registers. - -Fourth, `qt_cswap' needs to save and restore any floating-point -registers that are callee-save (see your processor handbook). On -some machines, *no* floating-point registers are callee-save, so -`qt_cswap' is exactly the same as the integer-only cswap routine. - -I suggest staring at the MIPS code for a few minutes. It's "mostly" -generic RISC code, so it gets a lot of the flavor across without -getting too bogged down in little nitty details. - - - -Now for a bit more detail: The stack is laid out to hold callee-save -registers. On many machines, I implemented fp cswap as save fp -regs, call integer cswap, and when integer cswap returns (when the -thread wakes up again), restore fp regs. - -For thread startup, I figure out some callee-save registers that -I use to hold parameters to the startup routine (`only'). When -the thread is being started it doesn't have any saved registers -that need to be restored, but I go ahead and let the integer context -switch routine restore some registers then "return" to the stub -code. The stub code then copies the "callee save" registers to -argument registers and calls the startup routine. That keeps the -stub code pretty darn simple. - -For each machine I need to know the machine's procedure calling -convention before I write a port. I figure out how many callee-save -registers are there and allocate enough stack space for those -registers. I also figure out how parameters are passed, since I -will need to call the helper function. On most RISC machines, I -just need to put the old sp in the 0'th arg register and then call -indirect through the 3rd arg register; the 1st and 2nd arg registers -are already set up correctly. Likewise, I don't touch the return -value register between the helper's return and the context switch -routine's return. - -I have a bunch of macros set up to do the stack initialization. -The easiest way to debug this stuff is to go ahead and write a C -routine to do stack initialization. Once you're happy with it you -can turn it in to a macro. - -In general there's a lot of ugly macros, but most of them do simple -things like return constants, etc. Any time you're looking at it -and it looks confusing you just need to remember "this is actually -simple code, the only tricky thing is calling the helper between -the stack switch and the new thread's register restore." - - -You will almost certainly need to write the assembly code fragment -that starts a thread. You might be able to do a lot of the context -switch code with `setjmp' and `longjmp', if they *happen* to have -the "right" implementation. But getting all the details right (the -helper can return a value to the new thread's cswap routine caller) -is probaby trickier than writing code that does the minimum and -thus doesn't have any extra instructions (or generality) to cause -problems. - -I don't know of any ports besides those included with the source -code distribution. If you send me a port I will hapily add it to -the distribution. - -Let me know as you have questions and/or comments. - - ;-D on ( Now *that*'s a switch... ) Pardo diff --git a/qt/aclocal.m4 b/qt/aclocal.m4 deleted file mode 100644 index a41f837ad..000000000 --- a/qt/aclocal.m4 +++ /dev/null @@ -1,167 +0,0 @@ -dnl aclocal.m4 generated automatically by aclocal 1.1l - - -dnl Usage: AM_INIT_GUILE_MODULE(module-name) -dnl This macro will automatically get the guile version from the -dnl top-level srcdir, and will initialize automake. It also -dnl defines the `module' variable. -AC_DEFUN([AM_INIT_GUILE_MODULE],[ -. $srcdir/../GUILE-VERSION -AM_INIT_AUTOMAKE($PACKAGE, $VERSION) -AC_CONFIG_AUX_DIR(..) -module=[$1] -AC_SUBST(module)]) - -# Do all the work for Automake. This macro actually does too much -- -# some checks are only needed if your package does certain things. -# But this isn't really a big deal. - -# serial 1 - -dnl Usage: -dnl AM_INIT_AUTOMAKE(package,version) - -AC_DEFUN(AM_INIT_AUTOMAKE, -[AC_REQUIRE([AM_PROG_INSTALL]) -PACKAGE=[$1] -AC_SUBST(PACKAGE) -AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE") -VERSION=[$2] -AC_SUBST(VERSION) -AC_DEFINE_UNQUOTED(VERSION, "$VERSION") -AM_SANITY_CHECK -AC_ARG_PROGRAM -AC_PROG_MAKE_SET]) - - -# serial 1 - -AC_DEFUN(AM_PROG_INSTALL, -[AC_REQUIRE([AC_PROG_INSTALL]) -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' -AC_SUBST(INSTALL_SCRIPT)dnl -]) - -# -# Check to make sure that the build environment is sane. -# - -AC_DEFUN(AM_SANITY_CHECK, -[AC_MSG_CHECKING([whether build environment is sane]) -echo timestamp > conftestfile -# Do this in a subshell so we don't clobber the current shell's -# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? -if (set X `ls -t $srcdir/configure conftestfile`; test "[$]2" = conftestfile) -then - # Ok. - : -else - AC_MSG_ERROR([newly created file is older than distributed files! -Check your system clock]) -fi -rm -f conftest* -AC_MSG_RESULT(yes)]) - -dnl -dnl CY_AC_WITH_THREADS determines which thread library the user intends -dnl to put underneath guile. Pass it the path to find the guile top-level -dnl source directory. Eg CY_AC_WITH_THREADS(../..) for tcl/unix. -dnl - -AC_DEFUN([CY_AC_WITH_THREADS],[ -AC_CACHE_CHECK("threads package type",cy_cv_threads_package,[ -AC_CACHE_VAL(cy_cv_threads_cflags,[ -AC_CACHE_VAL(cy_cv_threads_libs,[ -use_threads=no; -AC_ARG_WITH(threads,[ --with-threads thread interface], - use_threads=$withval, use_threads=no) -test -n "$use_threads" || use_threads=qt -threads_package=unknown -if test "$use_threads" != no; then -dnl -dnl Test for the qt threads package - used for cooperative threads -dnl This may not necessarily be built yet - so just check for the -dnl header files. -dnl - if test "$use_threads" = yes || test "$use_threads" = qt; then - # Look for qt in source directory. This is a hack: we look in - # "./qt" because this check might be run at the top level. - if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then - threads_package=COOP - cy_cv_threads_cflags="-I$srcdir/../qt -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - else - if test -f $use_threads/qt.c; then - # FIXME seems as though we should try to use an installed qt here. - threads_package=COOP - cy_cv_threads_cflags="-I$use_threads -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - fi - if test "$use_threads" = pthreads; then - # Look for pthreads in srcdir. See above to understand why - # we always set threads_package. - if test -f $srcdir/../../pthreads/pthreads/queue.c \ - || test -f $srcdir/../pthreads/pthreads/queue.c; then - threads_package=MIT - cy_cv_threads_cflags="-I$srcdir/../../pthreads/include" - cy_cv_threads_libs="-L../../pthreads/lib -lpthread" - fi - fi - saved_CPP="$CPPFLAGS" - saved_LD="$LDFLAGS" - saved_LIBS="$LIBS" - if test "$threads_package" = unknown; then -dnl -dnl Test for the FSU threads package -dnl - CPPFLAGS="-I$use_threads/include" - LDFLAGS="-L$use_threads/lib" - LIBS="-lgthreads -lmalloc" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=FSU) - fi - if test "$threads_package" = unknown; then -dnl -dnl Test for the MIT threads package -dnl - LIBS="-lpthread" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=MIT) - fi - if test "$threads_package" = unknown; then -dnl -dnl Test for the PCthreads package -dnl - LIBS="-lpthreads" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=PCthreads) - fi -dnl -dnl Set the appropriate flags! -dnl - cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags" - cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs" - cy_cv_threads_package=$threads_package - CPPFLAGS="$saved_CPP" - LDFLAGS="$saved_LD" - LIBS="$saved_LIBS" - if test "$threads_package" = unknown; then - AC_MSG_ERROR("cannot find thread library installation") - fi -fi -]) -]) -], -dnl -dnl Set flags according to what is cached. -dnl -CPPFLAGS="$cy_cv_threads_cflags" -LIBS="$cy_cv_threads_libs" -) -]) - diff --git a/qt/b.h b/qt/b.h deleted file mode 100644 index 862e78ba0..000000000 --- a/qt/b.h +++ /dev/null @@ -1,11 +0,0 @@ -#ifndef B_H -#define B_H "$Header: /home/ludo/src/guile.cvs/gitification/guile-cvs/guile/guile-core/qt/b.h,v 1.1 1996-10-01 03:27:25 mdj Exp $" - -#include "copyright.h" - -extern void b_call_reg (int n); -extern void b_call_imm (int n); -extern void b_add (int n); -extern void b_load (int n); - -#endif /* ndef B_H */ diff --git a/qt/config b/qt/config deleted file mode 100755 index 010071ddd..000000000 --- a/qt/config +++ /dev/null @@ -1,308 +0,0 @@ -#! /bin/sh -x - -rm -f Makefile Makefile.md README.md qtmd.h qtmdb.s qtmdc.c qtmds.s configuration - -case $1 in - axp*) - : "DEC AXP" - case $1 in - axp-osf1*) - : "Compile using /bin/cc under OSF 1.x." - ln -s md/axp.1.Makefile Makefile.md - ;; - axp-osf2*) - : "Compile using /bin/cc under OSF 2.x." - ln -s md/axp.1.Makefile Makefile.md - ;; - *) - : "Compile using GNU CC." - ln -s md/axp.Makefile Makefile.md - ;; - esac - - ln -s md/axp.h qtmd.h - ln -s md/axp.c qtmdc.c - ln -s md/axp.s qtmds.s - ln -s md/axp_b.s qtmdb.s - ln -s md/axp.README README.md - iter_init=1000000000 - iter_runone=10000000 - iter_blockint=10000000 - iter_blockfloat=10000000 - iter_vainit0=10000000 - iter_vainit2=10000000 - iter_vainit4=10000000 - iter_vainit8=10000000 - iter_vastart0=10000000 - iter_vastart2=10000000 - iter_vastart4=10000000 - iter_vastart8=10000000 - iter_bench_call_reg=10000000 - iter_bench_call_imm=10000000 - iter_bench_add=100000000 - iter_bench_load=100000000 - ;; - - hppa*) - : "HP's PA-RISC 1.1 processors." - - case $1 in - hppa-cnx-spp*) - : "Convex SPP (PA-RISC 1.1 processors)." - ln -s md/hppa-cnx.Makefile Makefile.md - ;; - *) - ln -s md/hppa.Makefile Makefile.md - ;; - esac - - ln -s md/hppa.h qtmd.h - ln -s md/null.c qtmdc.c - ln -s md/hppa.s qtmds.s - ln -s md/hppa_b.s qtmdb.s - iter_init=10000000 - iter_runone=1000000 - iter_blockint=1000000 - iter_blockfloat=1000000 - iter_vainit0=1000000 - iter_vainit2=1000000 - iter_vainit4=1000000 - iter_vainit8=1000000 - iter_vastart0=1000000 - iter_vastart2=1000000 - iter_vastart4=1000000 - iter_vastart8=1000000 - iter_bench_call_reg=10000000 - iter_bench_call_imm=10000000 - iter_bench_add=100000000 - iter_bench_load=100000000 - ;; - - iX86*) - case $1 in - iX86-ss*) - : "Assemlber comments '//'" - sed 's/\/\*/\/\//' < md/i386.s > qtmds.s - sed 's/\/\*/\/\//' < md/i386_b.s > qtmdb.s - ;; - - *) - ln -s md/i386.s qtmds.s - ln -s md/i386_b.s qtmdb.s - ;; - esac - : "Intel 80386 and compatibles (not '286...)" - ln -s md/default.Makefile Makefile.md - ln -s md/i386.h qtmd.h - ln -s md/null.c qtmdc.c - ln -s md/i386.README README.md - iter_init=10000000 - iter_runone=1000000 - iter_blockint=1000000 - iter_blockfloat=1000000 - iter_vainit0=1000000 - iter_vainit2=1000000 - iter_vainit4=1000000 - iter_vainit8=1000000 - iter_vastart0=1000000 - iter_vastart2=1000000 - iter_vastart4=1000000 - iter_vastart8=1000000 - iter_bench_call_reg=1000000 - iter_bench_call_imm=1000000 - iter_bench_add=100000000 - iter_bench_load=10000000 - ;; - - m68k) - : "Motorola 68000 family -- incomplete!" - ln -s md/default.Makefile Makefile.md - ln -s md/m68k.h qtmd.h - ln -s md/null.c qtmdc.c - ln -s md/m68k.s qtmds.s - ln -s md/m68k_b.s qtmdb.s - ln -s md/null.README README.md - ;; - - m88k) - : "Motorola 88000 family" - ln -s md/m88k.Makefile Makefile.md - ln -s md/m88k.h qtmd.h - ln -s md/m88k.c qtmdc.c - ln -s md/m88k.s qtmds.s - ln -s md/m88k_b.s qtmdb.s - ln -s md/null.README README.md - iter_init=1000000 - iter_runone=100000 - iter_blockint=100000 - iter_blockfloat=100000 - iter_vainit0=100000 - iter_vainit2=100000 - iter_vainit4=100000 - iter_vainit8=100000 - iter_vastart0=100000 - iter_vastart2=100000 - iter_vastart4=100000 - iter_vastart8=100000 - iter_bench_call_reg=100000000 - iter_bench_call_imm=100000000 - iter_bench_add=1000000000 - iter_bench_load=100000000 - ;; - - mips*) - : "MIPS R2000 and R3000." - - case $1 in - mips-irix5*) - : "Silicon Graphics Irix with dynamic linking" - : "Use mips for irix4." - ln -s md/mips-irix5.s qtmds.s - ;; - *) - ln -s md/mips.s qtmds.s - ;; - esac - - ln -s md/default.Makefile Makefile.md - ln -s md/mips.h qtmd.h - ln -s md/null.c qtmdc.c - ln -s md/mips_b.s qtmdb.s - ln -s md/null.README README.md - iter_init=10000000 - iter_runone=10000000 - iter_blockint=10000000 - iter_blockfloat=10000000 - iter_vainit0=1000000 - iter_vainit2=1000000 - iter_vainit4=1000000 - iter_vainit8=1000000 - iter_vastart0=1000000 - iter_vastart2=1000000 - iter_vastart4=1000000 - iter_vastart8=1000000 - iter_bench_call_reg=100000000 - iter_bench_call_imm=100000000 - iter_bench_add=1000000000 - iter_bench_load=100000000 - ;; - - sparc*) - : "SPARC processors" - case $1 in - sparc-os2*) - sed 's/_qt_/qt_/' md/sparc.s > qtmds.s - sed 's/_b_/b_/' md/sparc_b.s > qtmdb.s - ln -s md/solaris.README README.md - ;; - *) - ln -s md/sparc.s qtmds.s - ln -s md/sparc_b.s qtmdb.s - ln -s md/null.README README.md - ;; - esac - - ln -s md/default.Makefile Makefile.md - ln -s md/sparc.h qtmd.h - ln -s md/null.c qtmdc.c - iter_init=10000000 - iter_runone=1000000 - iter_blockint=1000000 - iter_blockfloat=1000000 - iter_vainit0=1000000 - iter_vainit2=1000000 - iter_vainit4=1000000 - iter_vainit8=1000000 - iter_vastart0=1000000 - iter_vastart2=1000000 - iter_vastart4=1000000 - iter_vastart8=1000000 - iter_bench_call_reg=10000000 - iter_bench_call_imm=10000000 - iter_bench_add=100000000 - iter_bench_load=100000000 - ;; - - vax*) - : "DEC VAX processors." - ln -s md/default.Makefile Makefile.md - ln -s md/vax.h qtmd.h - ln -s md/null.c qtmdc.c - ln -s md/vax.s qtmds.s - ln -s md/vax_b.s qtmdb.s - ln -s md/null.README README.md - iter_init=1000000 - iter_runone=100000 - iter_blockint=100000 - iter_blockfloat=100000 - iter_vainit0=100000 - iter_vainit2=100000 - iter_vainit4=100000 - iter_vainit8=100000 - iter_vastart0=100000 - iter_vastart2=100000 - iter_vastart4=100000 - iter_vastart8=100000 - iter_bench_call_reg=10000000 - iter_bench_call_imm=10000000 - iter_bench_add=10000000 - iter_bench_load=1000000 - ;; - - ksr1) - : "Kendall Square Research model KSR-1." - : "Varargs is not currently supported." - ln -s md/ksr1.Makefile Makefile.md - ln -s md/ksr1.h qtmd.h - ln -s md/null.c qtmdc.c - ln -s md/ksr1.s qtmds.s - ln -s md/ksr1_b.s qtmdb.s - ln -s md/null.README README.md - iter_init=1000000 - iter_runone=100000 - iter_blockint=100000 - iter_blockfloat=100000 - iter_vainit0=100000 - iter_vainit2=100000 - iter_vainit4=100000 - iter_vainit8=100000 - iter_vastart0=100000 - iter_vastart2=100000 - iter_vastart4=100000 - iter_vastart8=100000 - iter_bench_call_reg=10000000 - iter_bench_call_imm=10000000 - iter_bench_add=10000000 - iter_bench_load=1000000 - ;; - - clean) - : Deconfigure - exit 0 - ;; - - *) - echo "Unknown configuration" - exit 1 - ;; -esac - -cat Makefile.md Makefile.base > Makefile - -echo set config_machine=$1 >> configuration -echo set config_init=$iter_init >> configuration -echo set config_runone=$iter_runone >> configuration -echo set config_blockint=$iter_blockint >> configuration -echo set config_blockfloat=$iter_blockfloat >> configuration -echo set config_vainit0=$iter_vainit0 >> configuration -echo set config_vainit2=$iter_vainit2 >> configuration -echo set config_vainit4=$iter_vainit4 >> configuration -echo set config_vainit8=$iter_vainit8 >> configuration -echo set config_vastart0=$iter_vastart0 >> configuration -echo set config_vastart2=$iter_vastart2 >> configuration -echo set config_vastart4=$iter_vastart4 >> configuration -echo set config_vastart8=$iter_vastart8 >> configuration -echo set config_bcall_reg=$iter_bench_call_reg >> configuration -echo set config_bcall_imm=$iter_bench_call_imm >> configuration -echo set config_b_add=$iter_bench_add >> configuration -echo set config_b_load=$iter_bench_load >> configuration diff --git a/qt/configure b/qt/configure deleted file mode 100755 index 6a89eb809..000000000 --- a/qt/configure +++ /dev/null @@ -1,1473 +0,0 @@ -#! /bin/sh - -# Guess values for system-dependent variables and create Makefiles. -# Generated automatically using autoconf version 2.12 -# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc. -# -# This configure script is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - -# Defaults: -ac_help= -ac_default_prefix=/usr/local -# Any additions from configure.in: -ac_help="$ac_help - --with-threads thread interface" - -# Initialize some variables set by options. -# The variables have the same names as the options, with -# dashes changed to underlines. -build=NONE -cache_file=./config.cache -exec_prefix=NONE -host=NONE -no_create= -nonopt=NONE -no_recursion= -prefix=NONE -program_prefix=NONE -program_suffix=NONE -program_transform_name=s,x,x, -silent= -site= -srcdir= -target=NONE -verbose= -x_includes=NONE -x_libraries=NONE -bindir='${exec_prefix}/bin' -sbindir='${exec_prefix}/sbin' -libexecdir='${exec_prefix}/libexec' -datadir='${prefix}/share' -sysconfdir='${prefix}/etc' -sharedstatedir='${prefix}/com' -localstatedir='${prefix}/var' -libdir='${exec_prefix}/lib' -includedir='${prefix}/include' -oldincludedir='/usr/include' -infodir='${prefix}/info' -mandir='${prefix}/man' - -# Initialize some other variables. -subdirs= -MFLAGS= MAKEFLAGS= -# Maximum number of lines to put in a shell here document. -ac_max_here_lines=12 - -ac_prev= -for ac_option -do - - # If the previous option needs an argument, assign it. - if test -n "$ac_prev"; then - eval "$ac_prev=\$ac_option" - ac_prev= - continue - fi - - case "$ac_option" in - -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; - *) ac_optarg= ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. - - case "$ac_option" in - - -bindir | --bindir | --bindi | --bind | --bin | --bi) - ac_prev=bindir ;; - -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) - bindir="$ac_optarg" ;; - - -build | --build | --buil | --bui | --bu) - ac_prev=build ;; - -build=* | --build=* | --buil=* | --bui=* | --bu=*) - build="$ac_optarg" ;; - - -cache-file | --cache-file | --cache-fil | --cache-fi \ - | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) - ac_prev=cache_file ;; - -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ - | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) - cache_file="$ac_optarg" ;; - - -datadir | --datadir | --datadi | --datad | --data | --dat | --da) - ac_prev=datadir ;; - -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ - | --da=*) - datadir="$ac_optarg" ;; - - -disable-* | --disable-*) - ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - eval "enable_${ac_feature}=no" ;; - - -enable-* | --enable-*) - ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } - fi - ac_feature=`echo $ac_feature| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "enable_${ac_feature}='$ac_optarg'" ;; - - -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ - | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ - | --exec | --exe | --ex) - ac_prev=exec_prefix ;; - -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ - | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ - | --exec=* | --exe=* | --ex=*) - exec_prefix="$ac_optarg" ;; - - -gas | --gas | --ga | --g) - # Obsolete; use --with-gas. - with_gas=yes ;; - - -help | --help | --hel | --he) - # Omit some internal or obsolete options to make the list less imposing. - # This message is too long to be a string in the A/UX 3.1 sh. - cat << EOF -Usage: configure [options] [host] -Options: [defaults in brackets after descriptions] -Configuration: - --cache-file=FILE cache test results in FILE - --help print this message - --no-create do not create output files - --quiet, --silent do not print \`checking...' messages - --version print the version of autoconf that created configure -Directory and file names: - --prefix=PREFIX install architecture-independent files in PREFIX - [$ac_default_prefix] - --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX - [same as prefix] - --bindir=DIR user executables in DIR [EPREFIX/bin] - --sbindir=DIR system admin executables in DIR [EPREFIX/sbin] - --libexecdir=DIR program executables in DIR [EPREFIX/libexec] - --datadir=DIR read-only architecture-independent data in DIR - [PREFIX/share] - --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc] - --sharedstatedir=DIR modifiable architecture-independent data in DIR - [PREFIX/com] - --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var] - --libdir=DIR object code libraries in DIR [EPREFIX/lib] - --includedir=DIR C header files in DIR [PREFIX/include] - --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include] - --infodir=DIR info documentation in DIR [PREFIX/info] - --mandir=DIR man documentation in DIR [PREFIX/man] - --srcdir=DIR find the sources in DIR [configure dir or ..] - --program-prefix=PREFIX prepend PREFIX to installed program names - --program-suffix=SUFFIX append SUFFIX to installed program names - --program-transform-name=PROGRAM - run sed PROGRAM on installed program names -EOF - cat << EOF -Host type: - --build=BUILD configure for building on BUILD [BUILD=HOST] - --host=HOST configure for HOST [guessed] - --target=TARGET configure for TARGET [TARGET=HOST] -Features and packages: - --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) - --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] - --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --x-includes=DIR X include files are in DIR - --x-libraries=DIR X library files are in DIR -EOF - if test -n "$ac_help"; then - echo "--enable and --with options recognized:$ac_help" - fi - exit 0 ;; - - -host | --host | --hos | --ho) - ac_prev=host ;; - -host=* | --host=* | --hos=* | --ho=*) - host="$ac_optarg" ;; - - -includedir | --includedir | --includedi | --included | --include \ - | --includ | --inclu | --incl | --inc) - ac_prev=includedir ;; - -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ - | --includ=* | --inclu=* | --incl=* | --inc=*) - includedir="$ac_optarg" ;; - - -infodir | --infodir | --infodi | --infod | --info | --inf) - ac_prev=infodir ;; - -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) - infodir="$ac_optarg" ;; - - -libdir | --libdir | --libdi | --libd) - ac_prev=libdir ;; - -libdir=* | --libdir=* | --libdi=* | --libd=*) - libdir="$ac_optarg" ;; - - -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ - | --libexe | --libex | --libe) - ac_prev=libexecdir ;; - -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ - | --libexe=* | --libex=* | --libe=*) - libexecdir="$ac_optarg" ;; - - -localstatedir | --localstatedir | --localstatedi | --localstated \ - | --localstate | --localstat | --localsta | --localst \ - | --locals | --local | --loca | --loc | --lo) - ac_prev=localstatedir ;; - -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ - | --localstate=* | --localstat=* | --localsta=* | --localst=* \ - | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) - localstatedir="$ac_optarg" ;; - - -mandir | --mandir | --mandi | --mand | --man | --ma | --m) - ac_prev=mandir ;; - -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) - mandir="$ac_optarg" ;; - - -nfp | --nfp | --nf) - # Obsolete; use --without-fp. - with_fp=no ;; - - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) - no_create=yes ;; - - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) - no_recursion=yes ;; - - -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ - | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ - | --oldin | --oldi | --old | --ol | --o) - ac_prev=oldincludedir ;; - -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ - | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ - | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) - oldincludedir="$ac_optarg" ;; - - -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) - ac_prev=prefix ;; - -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) - prefix="$ac_optarg" ;; - - -program-prefix | --program-prefix | --program-prefi | --program-pref \ - | --program-pre | --program-pr | --program-p) - ac_prev=program_prefix ;; - -program-prefix=* | --program-prefix=* | --program-prefi=* \ - | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) - program_prefix="$ac_optarg" ;; - - -program-suffix | --program-suffix | --program-suffi | --program-suff \ - | --program-suf | --program-su | --program-s) - ac_prev=program_suffix ;; - -program-suffix=* | --program-suffix=* | --program-suffi=* \ - | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) - program_suffix="$ac_optarg" ;; - - -program-transform-name | --program-transform-name \ - | --program-transform-nam | --program-transform-na \ - | --program-transform-n | --program-transform- \ - | --program-transform | --program-transfor \ - | --program-transfo | --program-transf \ - | --program-trans | --program-tran \ - | --progr-tra | --program-tr | --program-t) - ac_prev=program_transform_name ;; - -program-transform-name=* | --program-transform-name=* \ - | --program-transform-nam=* | --program-transform-na=* \ - | --program-transform-n=* | --program-transform-=* \ - | --program-transform=* | --program-transfor=* \ - | --program-transfo=* | --program-transf=* \ - | --program-trans=* | --program-tran=* \ - | --progr-tra=* | --program-tr=* | --program-t=*) - program_transform_name="$ac_optarg" ;; - - -q | -quiet | --quiet | --quie | --qui | --qu | --q \ - | -silent | --silent | --silen | --sile | --sil) - silent=yes ;; - - -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) - ac_prev=sbindir ;; - -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ - | --sbi=* | --sb=*) - sbindir="$ac_optarg" ;; - - -sharedstatedir | --sharedstatedir | --sharedstatedi \ - | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ - | --sharedst | --shareds | --shared | --share | --shar \ - | --sha | --sh) - ac_prev=sharedstatedir ;; - -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ - | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ - | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ - | --sha=* | --sh=*) - sharedstatedir="$ac_optarg" ;; - - -site | --site | --sit) - ac_prev=site ;; - -site=* | --site=* | --sit=*) - site="$ac_optarg" ;; - - -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) - ac_prev=srcdir ;; - -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) - srcdir="$ac_optarg" ;; - - -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ - | --syscon | --sysco | --sysc | --sys | --sy) - ac_prev=sysconfdir ;; - -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ - | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) - sysconfdir="$ac_optarg" ;; - - -target | --target | --targe | --targ | --tar | --ta | --t) - ac_prev=target ;; - -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) - target="$ac_optarg" ;; - - -v | -verbose | --verbose | --verbos | --verbo | --verb) - verbose=yes ;; - - -version | --version | --versio | --versi | --vers) - echo "configure generated by autoconf version 2.12" - exit 0 ;; - - -with-* | --with-*) - ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - case "$ac_option" in - *=*) ;; - *) ac_optarg=yes ;; - esac - eval "with_${ac_package}='$ac_optarg'" ;; - - -without-* | --without-*) - ac_package=`echo $ac_option|sed -e 's/-*without-//'` - # Reject names that are not valid shell variable names. - if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then - { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } - fi - ac_package=`echo $ac_package| sed 's/-/_/g'` - eval "with_${ac_package}=no" ;; - - --x) - # Obsolete; use --with-x. - with_x=yes ;; - - -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ - | --x-incl | --x-inc | --x-in | --x-i) - ac_prev=x_includes ;; - -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ - | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) - x_includes="$ac_optarg" ;; - - -x-libraries | --x-libraries | --x-librarie | --x-librari \ - | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) - ac_prev=x_libraries ;; - -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries="$ac_optarg" ;; - - -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } - ;; - - *) - if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then - echo "configure: warning: $ac_option: invalid host type" 1>&2 - fi - if test "x$nonopt" != xNONE; then - { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } - fi - nonopt="$ac_option" - ;; - - esac -done - -if test -n "$ac_prev"; then - { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } -fi - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -# File descriptor usage: -# 0 standard input -# 1 file creation -# 2 errors and warnings -# 3 some systems may open it to /dev/tty -# 4 used on the Kubota Titan -# 6 checking for... messages and results -# 5 compiler messages saved in config.log -if test "$silent" = yes; then - exec 6>/dev/null -else - exec 6>&1 -fi -exec 5>./config.log - -echo "\ -This file contains any messages produced by compilers while -running configure, to aid debugging if configure makes a mistake. -" 1>&5 - -# Strip out --no-create and --no-recursion so they do not pile up. -# Also quote any args containing shell metacharacters. -ac_configure_args= -for ac_arg -do - case "$ac_arg" in - -no-create | --no-create | --no-creat | --no-crea | --no-cre \ - | --no-cr | --no-c) ;; - -no-recursion | --no-recursion | --no-recursio | --no-recursi \ - | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; - *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) - ac_configure_args="$ac_configure_args '$ac_arg'" ;; - *) ac_configure_args="$ac_configure_args $ac_arg" ;; - esac -done - -# NLS nuisances. -# Only set these to C if already set. These must not be set unconditionally -# because not all systems understand e.g. LANG=C (notably SCO). -# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'! -# Non-C LC_CTYPE values break the ctype check. -if test "${LANG+set}" = set; then LANG=C; export LANG; fi -if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi -if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi -if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi - -# confdefs.h avoids OS command line length limits that DEFS can exceed. -rm -rf conftest* confdefs.h -# AIX cpp loses on an empty file, so make sure it contains at least a newline. -echo > confdefs.h - -# A filename unique to this package, relative to the directory that -# configure is in, which we can look for to find out if srcdir is correct. -ac_unique_file=qt.c - -# Find the source files, if location was not specified. -if test -z "$srcdir"; then - ac_srcdir_defaulted=yes - # Try the directory containing this script, then its parent. - ac_prog=$0 - ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` - test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. - srcdir=$ac_confdir - if test ! -r $srcdir/$ac_unique_file; then - srcdir=.. - fi -else - ac_srcdir_defaulted=no -fi -if test ! -r $srcdir/$ac_unique_file; then - if test "$ac_srcdir_defaulted" = yes; then - { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } - else - { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } - fi -fi -srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` - -# Prefer explicitly selected file to automatically selected ones. -if test -z "$CONFIG_SITE"; then - if test "x$prefix" != xNONE; then - CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" - else - CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" - fi -fi -for ac_site_file in $CONFIG_SITE; do - if test -r "$ac_site_file"; then - echo "loading site script $ac_site_file" - . "$ac_site_file" - fi -done - -if test -r "$cache_file"; then - echo "loading cache $cache_file" - . $cache_file -else - echo "creating cache $cache_file" - > $cache_file -fi - -ac_ext=c -# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. -ac_cpp='$CPP $CPPFLAGS' -ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' -ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' -cross_compiling=$ac_cv_prog_cc_cross - -if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then - # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. - if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then - ac_n= ac_c=' -' ac_t=' ' - else - ac_n=-n ac_c= ac_t= - fi -else - ac_n= ac_c='\c' ac_t= -fi - - -ac_aux_dir= -for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do - if test -f $ac_dir/install-sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f $ac_dir/install.sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - fi -done -if test -z "$ac_aux_dir"; then - { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } -fi -ac_config_guess=$ac_aux_dir/config.guess -ac_config_sub=$ac_aux_dir/config.sub -ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. - -# Find a good install program. We prefer a C program (faster), -# so one script is as good as another. But avoid the broken or -# incompatible versions: -# SysV /etc/install, /usr/sbin/install -# SunOS /usr/etc/install -# IRIX /sbin/install -# AIX /bin/install -# AFS /usr/afsws/bin/install, which mishandles nonexistent args -# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" -# ./install, which can be erroneously created by make from ./install.sh. -echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 -echo "configure:554: checking for a BSD compatible install" >&5 -if test -z "$INSTALL"; then -if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - # Account for people who put trailing slashes in PATH elements. - case "$ac_dir/" in - /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; - *) - # OSF1 and SCO ODT 3.0 have their own names for install. - for ac_prog in ginstall installbsd scoinst install; do - if test -f $ac_dir/$ac_prog; then - if test $ac_prog = install && - grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then - # AIX install. It has an incompatible calling convention. - # OSF/1 installbsd also uses dspmsg, but is usable. - : - else - ac_cv_path_install="$ac_dir/$ac_prog -c" - break 2 - fi - fi - done - ;; - esac - done - IFS="$ac_save_IFS" - -fi - if test "${ac_cv_path_install+set}" = set; then - INSTALL="$ac_cv_path_install" - else - # As a last resort, use the slow shell script. We don't cache a - # path for INSTALL within a source directory, because that will - # break other packages using the cache if that directory is - # removed, or if the path is relative. - INSTALL="$ac_install_sh" - fi -fi -echo "$ac_t""$INSTALL" 1>&6 - -# Use test -z because SunOS4 sh mishandles braces in ${var-val}. -# It thinks the first close brace ends the variable substitution. -test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' - -test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' - - -test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}' - - -. $srcdir/../GUILE-VERSION - -PACKAGE=$PACKAGE - -cat >> confdefs.h <<EOF -#define PACKAGE "$PACKAGE" -EOF - -VERSION=$VERSION - -cat >> confdefs.h <<EOF -#define VERSION "$VERSION" -EOF - -echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6 -echo "configure:622: checking whether build environment is sane" >&5 -echo timestamp > conftestfile -# Do this in a subshell so we don't clobber the current shell's -# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test? -if (set X `ls -t $srcdir/configure conftestfile`; test "$2" = conftestfile) -then - # Ok. - : -else - { echo "configure: error: newly created file is older than distributed files! -Check your system clock" 1>&2; exit 1; } -fi -rm -f conftest* -echo "$ac_t""yes" 1>&6 -if test "$program_transform_name" = s,x,x,; then - program_transform_name= -else - # Double any \ or $. echo might interpret backslashes. - cat <<\EOF_SED > conftestsed -s,\\,\\\\,g; s,\$,$$,g -EOF_SED - program_transform_name="`echo $program_transform_name|sed -f conftestsed`" - rm -f conftestsed -fi -test "$program_prefix" != NONE && - program_transform_name="s,^,${program_prefix},; $program_transform_name" -# Use a double $ so make ignores it. -test "$program_suffix" != NONE && - program_transform_name="s,\$\$,${program_suffix},; $program_transform_name" - -# sed with no file args requires a program. -test "$program_transform_name" = "" && program_transform_name="s,x,x," - -echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6 -echo "configure:656: checking whether ${MAKE-make} sets \${MAKE}" >&5 -set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'` -if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftestmake <<\EOF -all: - @echo 'ac_maketemp="${MAKE}"' -EOF -# GNU make sometimes prints "make[1]: Entering...", which would confuse us. -eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=` -if test -n "$ac_maketemp"; then - eval ac_cv_prog_make_${ac_make}_set=yes -else - eval ac_cv_prog_make_${ac_make}_set=no -fi -rm -f conftestmake -fi -if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then - echo "$ac_t""yes" 1>&6 - SET_MAKE= -else - echo "$ac_t""no" 1>&6 - SET_MAKE="MAKE=${MAKE-make}" -fi - -ac_aux_dir= -for ac_dir in .. $srcdir/..; do - if test -f $ac_dir/install-sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install-sh -c" - break - elif test -f $ac_dir/install.sh; then - ac_aux_dir=$ac_dir - ac_install_sh="$ac_aux_dir/install.sh -c" - break - fi -done -if test -z "$ac_aux_dir"; then - { echo "configure: error: can not find install-sh or install.sh in .. $srcdir/.." 1>&2; exit 1; } -fi -ac_config_guess=$ac_aux_dir/config.guess -ac_config_sub=$ac_aux_dir/config.sub -ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. - -module=qt - - -# Extract the first word of "gcc", so it can be a program name with args. -set dummy gcc; ac_word=$2 -echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:707: checking for $ac_word" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - test -z "$ac_dir" && ac_dir=. - if test -f $ac_dir/$ac_word; then - ac_cv_prog_CC="gcc" - break - fi - done - IFS="$ac_save_ifs" -fi -fi -CC="$ac_cv_prog_CC" -if test -n "$CC"; then - echo "$ac_t""$CC" 1>&6 -else - echo "$ac_t""no" 1>&6 -fi - -if test -z "$CC"; then - # Extract the first word of "cc", so it can be a program name with args. -set dummy cc; ac_word=$2 -echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:736: checking for $ac_word" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - if test -n "$CC"; then - ac_cv_prog_CC="$CC" # Let the user override the test. -else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" - ac_prog_rejected=no - for ac_dir in $PATH; do - test -z "$ac_dir" && ac_dir=. - if test -f $ac_dir/$ac_word; then - if test "$ac_dir/$ac_word" = "/usr/ucb/cc"; then - ac_prog_rejected=yes - continue - fi - ac_cv_prog_CC="cc" - break - fi - done - IFS="$ac_save_ifs" -if test $ac_prog_rejected = yes; then - # We found a bogon in the path, so make sure we never use it. - set dummy $ac_cv_prog_CC - shift - if test $# -gt 0; then - # We chose a different compiler from the bogus one. - # However, it has the same basename, so the bogon will be chosen - # first if we set CC to just the basename; use the full file name. - shift - set dummy "$ac_dir/$ac_word" "$@" - shift - ac_cv_prog_CC="$@" - fi -fi -fi -fi -CC="$ac_cv_prog_CC" -if test -n "$CC"; then - echo "$ac_t""$CC" 1>&6 -else - echo "$ac_t""no" 1>&6 -fi - - test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; } -fi - -echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6 -echo "configure:784: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5 - -ac_ext=c -# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. -ac_cpp='$CPP $CPPFLAGS' -ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5' -ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5' -cross_compiling=$ac_cv_prog_cc_cross - -cat > conftest.$ac_ext <<EOF -#line 794 "configure" -#include "confdefs.h" -main(){return(0);} -EOF -if { (eval echo configure:798: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - ac_cv_prog_cc_works=yes - # If we can't run a trivial program, we are probably using a cross compiler. - if (./conftest; exit) 2>/dev/null; then - ac_cv_prog_cc_cross=no - else - ac_cv_prog_cc_cross=yes - fi -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - ac_cv_prog_cc_works=no -fi -rm -fr conftest* - -echo "$ac_t""$ac_cv_prog_cc_works" 1>&6 -if test $ac_cv_prog_cc_works = no; then - { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; } -fi -echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6 -echo "configure:818: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5 -echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6 -cross_compiling=$ac_cv_prog_cc_cross - -echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6 -echo "configure:823: checking whether we are using GNU C" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - cat > conftest.c <<EOF -#ifdef __GNUC__ - yes; -#endif -EOF -if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:832: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then - ac_cv_prog_gcc=yes -else - ac_cv_prog_gcc=no -fi -fi - -echo "$ac_t""$ac_cv_prog_gcc" 1>&6 - -if test $ac_cv_prog_gcc = yes; then - GCC=yes - ac_test_CFLAGS="${CFLAGS+set}" - ac_save_CFLAGS="$CFLAGS" - CFLAGS= - echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 -echo "configure:847: checking whether ${CC-cc} accepts -g" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - echo 'void f(){}' > conftest.c -if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then - ac_cv_prog_cc_g=yes -else - ac_cv_prog_cc_g=no -fi -rm -f conftest* - -fi - -echo "$ac_t""$ac_cv_prog_cc_g" 1>&6 - if test "$ac_test_CFLAGS" = set; then - CFLAGS="$ac_save_CFLAGS" - elif test $ac_cv_prog_cc_g = yes; then - CFLAGS="-g -O2" - else - CFLAGS="-O2" - fi -else - GCC= - test "${CFLAGS+set}" = set || CFLAGS="-g" -fi - -echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 -echo "configure:875: checking how to run the C preprocessor" >&5 -# On Suns, sometimes $CPP names a directory. -if test -n "$CPP" && test -d "$CPP"; then - CPP= -fi -if test -z "$CPP"; then -if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - # This must be in double quotes, not single quotes, because CPP may get - # substituted into the Makefile and "${CC-cc}" will confuse make. - CPP="${CC-cc} -E" - # On the NeXT, cc -E runs the code through the compiler's parser, - # not just through cpp. - cat > conftest.$ac_ext <<EOF -#line 890 "configure" -#include "confdefs.h" -#include <assert.h> -Syntax Error -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:896: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - : -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - CPP="${CC-cc} -E -traditional-cpp" - cat > conftest.$ac_ext <<EOF -#line 907 "configure" -#include "confdefs.h" -#include <assert.h> -Syntax Error -EOF -ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" -{ (eval echo configure:913: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; } -ac_err=`grep -v '^ *+' conftest.out` -if test -z "$ac_err"; then - : -else - echo "$ac_err" >&5 - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 - rm -rf conftest* - CPP=/lib/cpp -fi -rm -f conftest* -fi -rm -f conftest* - ac_cv_prog_CPP="$CPP" -fi - CPP="$ac_cv_prog_CPP" -else - ac_cv_prog_CPP="$CPP" -fi -echo "$ac_t""$CPP" 1>&6 - -# Extract the first word of "ranlib", so it can be a program name with args. -set dummy ranlib; ac_word=$2 -echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 -echo "configure:938: checking for $ac_word" >&5 -if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - if test -n "$RANLIB"; then - ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. -else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - test -z "$ac_dir" && ac_dir=. - if test -f $ac_dir/$ac_word; then - ac_cv_prog_RANLIB="ranlib" - break - fi - done - IFS="$ac_save_ifs" - test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" -fi -fi -RANLIB="$ac_cv_prog_RANLIB" -if test -n "$RANLIB"; then - echo "$ac_t""$RANLIB" 1>&6 -else - echo "$ac_t""no" 1>&6 -fi - - - -echo $ac_n "checking "threads package type"""... $ac_c" 1>&6 -echo "configure:967: checking "threads package type"" >&5 -if eval "test \"`echo '$''{'cy_cv_threads_package'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - -if eval "test \"`echo '$''{'cy_cv_threads_cflags'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - -if eval "test \"`echo '$''{'cy_cv_threads_libs'+set}'`\" = set"; then - echo $ac_n "(cached) $ac_c" 1>&6 -else - -use_threads=no; -# Check whether --with-threads or --without-threads was given. -if test "${with_threads+set}" = set; then - withval="$with_threads" - use_threads=$withval -else - use_threads=no -fi - -test -n "$use_threads" || use_threads=qt -threads_package=unknown -if test "$use_threads" != no; then - if test "$use_threads" = yes || test "$use_threads" = qt; then - # Look for qt in source directory. This is a hack: we look in - # "./qt" because this check might be run at the top level. - if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then - threads_package=COOP - cy_cv_threads_cflags="-I$srcdir/../qt -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - else - if test -f $use_threads/qt.c; then - # FIXME seems as though we should try to use an installed qt here. - threads_package=COOP - cy_cv_threads_cflags="-I$use_threads -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - fi - if test "$use_threads" = pthreads; then - # Look for pthreads in srcdir. See above to understand why - # we always set threads_package. - if test -f $srcdir/../../pthreads/pthreads/queue.c \ - || test -f $srcdir/../pthreads/pthreads/queue.c; then - threads_package=MIT - cy_cv_threads_cflags="-I$srcdir/../../pthreads/include" - cy_cv_threads_libs="-L../../pthreads/lib -lpthread" - fi - fi - saved_CPP="$CPPFLAGS" - saved_LD="$LDFLAGS" - saved_LIBS="$LIBS" - if test "$threads_package" = unknown; then - CPPFLAGS="-I$use_threads/include" - LDFLAGS="-L$use_threads/lib" - LIBS="-lgthreads -lmalloc" - cat > conftest.$ac_ext <<EOF -#line 1026 "configure" -#include "confdefs.h" -#include <pthread.h> -int main() { - -pthread_equal(NULL,NULL); - -; return 0; } -EOF -if { (eval echo configure:1035: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - threads_package=FSU -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* - fi - if test "$threads_package" = unknown; then - LIBS="-lpthread" - cat > conftest.$ac_ext <<EOF -#line 1047 "configure" -#include "confdefs.h" -#include <pthread.h> -int main() { - -pthread_equal(NULL,NULL); - -; return 0; } -EOF -if { (eval echo configure:1056: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - threads_package=MIT -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* - fi - if test "$threads_package" = unknown; then - LIBS="-lpthreads" - cat > conftest.$ac_ext <<EOF -#line 1068 "configure" -#include "confdefs.h" -#include <pthread.h> -int main() { - -pthread_equal(NULL,NULL); - -; return 0; } -EOF -if { (eval echo configure:1077: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then - rm -rf conftest* - threads_package=PCthreads -else - echo "configure: failed program was:" >&5 - cat conftest.$ac_ext >&5 -fi -rm -f conftest* - fi - cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags" - cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs" - cy_cv_threads_package=$threads_package - CPPFLAGS="$saved_CPP" - LDFLAGS="$saved_LD" - LIBS="$saved_LIBS" - if test "$threads_package" = unknown; then - { echo "configure: error: "cannot find thread library installation"" 1>&2; exit 1; } - fi -fi - -fi - - -fi - - -fi - -echo "$ac_t""$cy_cv_threads_package" 1>&6 - - -threads_enabled=false -if test "$cy_cv_threads_package" = COOP; then - threads_enabled=true -fi - -# Determine the host we are working on - -# Make sure we can run config.sub. -if $ac_config_sub sun4 >/dev/null 2>&1; then : -else { echo "configure: error: can not run $ac_config_sub" 1>&2; exit 1; } -fi - -echo $ac_n "checking host system type""... $ac_c" 1>&6 -echo "configure:1121: checking host system type" >&5 - -host_alias=$host -case "$host_alias" in -NONE) - case $nonopt in - NONE) - if host_alias=`$ac_config_guess`; then : - else { echo "configure: error: can not guess host type; you must specify one" 1>&2; exit 1; } - fi ;; - *) host_alias=$nonopt ;; - esac ;; -esac - -host=`$ac_config_sub $host_alias` -host_cpu=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` -host_vendor=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` -host_os=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` -echo "$ac_t""$host" 1>&6 - - -case "$host" in -i386-*-*|i486-*-*|i586-*-*) - qtmds_s=$srcdir/md/i386.s - qtmd_h=$srcdir/md/i386.h - qtmdc_c=$srcdir/md/null.c - ;; -mips-sgi-irix5*) - qtmds_s=$srcdir/md/mips-irix5.s - qtmd_h=$srcdir/md/mips.h - qtmdc_c=$srcdir/md/null.c - qtdmdb_s=$srcdir/md/mips_b.s - ;; -mips-*-*) - qtmds_s=$srcdir/md/mips.s - qtmd_h=$srcdir/md/mips.h - qtmdc_c=$srcdir/md/null.c - qtdmdb_s=$srcdir/md/mips_b.s - ;; -sparc-sun-solaris2.*) - qtmd_h=$srcdir/md/sparc.h - qtmdc_c=$srcdir/md/null.c - qtmds_s=$srcdir/md/sparc.s - qtdmdb_s=$srcdir/md/sparc_b.s - ;; -sparc-*-*) - qtmd_h=$srcdir/md/sparc.h - qtmdc_c=$srcdir/md/null.c - qtmds_s=$srcdir/md/_sparc.s - qtdmdb_s=$srcdir/md/_sparc_b.s - ;; -*) - echo "Unknown configuration; threads package disabled" - threads_enabled=false - ;; -esac - - -if $threads_enabled; then - target_libs=libqt.a -else - target_libs= -fi - -# Give the Makefile the names of the object files that will be -# generated by compiling $qtmdc_c and $qtmds_s. -qtmdc_o="`echo ${qtmdc_c} | sed -e 's:^.*/::' | sed -e 's:\.c$:\.o:'`" -qtmds_o="`echo ${qtmds_s} | sed -e 's:^.*/::' | sed -e 's:\.s$:\.o:'`" - - - - - - - - - -trap '' 1 2 15 -cat > confcache <<\EOF -# This file is a shell script that caches the results of configure -# tests run on this system so they can be shared between configure -# scripts and configure runs. It is not useful on other systems. -# If it contains results you don't want to keep, you may remove or edit it. -# -# By default, configure uses ./config.cache as the cache file, -# creating it if it does not exist already. You can give configure -# the --cache-file=FILE option to use a different cache file; that is -# what configure does when it calls configure scripts in -# subdirectories, so they share the cache. -# Giving --cache-file=/dev/null disables caching, for debugging configure. -# config.status only pays attention to the cache file if you give it the -# --recheck option to rerun configure. -# -EOF -# The following way of writing the cache mishandles newlines in values, -# but we know of no workaround that is simple, portable, and efficient. -# So, don't put newlines in cache variables' values. -# Ultrix sh set writes to stderr and can't be redirected directly, -# and sets the high bit in the cache file unless we assign to the vars. -(set) 2>&1 | - case `(ac_space=' '; set) 2>&1` in - *ac_space=\ *) - # `set' does not quote correctly, so add quotes (double-quote substitution - # turns \\\\ into \\, and sed turns \\ into \). - sed -n \ - -e "s/'/'\\\\''/g" \ - -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p" - ;; - *) - # `set' quotes correctly as required by POSIX, so do not add quotes. - sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p' - ;; - esac >> confcache -if cmp -s $cache_file confcache; then - : -else - if test -w $cache_file; then - echo "updating cache $cache_file" - cat confcache > $cache_file - else - echo "not updating unwritable cache $cache_file" - fi -fi -rm -f confcache - -trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 - -test "x$prefix" = xNONE && prefix=$ac_default_prefix -# Let make expand exec_prefix. -test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' - -# Any assignment to VPATH causes Sun make to only execute -# the first set of double-colon rules, so remove it if not needed. -# If there is a colon in the path, we need to keep it. -if test "x$srcdir" = x.; then - ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' -fi - -trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 - -# Transform confdefs.h into DEFS. -# Protect against shell expansion while executing Makefile rules. -# Protect against Makefile macro expansion. -cat > conftest.defs <<\EOF -s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g -s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g -s%\[%\\&%g -s%\]%\\&%g -s%\$%$$%g -EOF -DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` -rm -f conftest.defs - - -# Without the "./", some shells look in PATH for config.status. -: ${CONFIG_STATUS=./config.status} - -echo creating $CONFIG_STATUS -rm -f $CONFIG_STATUS -cat > $CONFIG_STATUS <<EOF -#! /bin/sh -# Generated automatically by configure. -# Run this file to recreate the current configuration. -# This directory was configured as follows, -# on host `(hostname || uname -n) 2>/dev/null | sed 1q`: -# -# $0 $ac_configure_args -# -# Compiler output produced by configure, useful for debugging -# configure, is in ./config.log if it exists. - -ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" -for ac_option -do - case "\$ac_option" in - -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) - echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" - exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; - -version | --version | --versio | --versi | --vers | --ver | --ve | --v) - echo "$CONFIG_STATUS generated by autoconf version 2.12" - exit 0 ;; - -help | --help | --hel | --he | --h) - echo "\$ac_cs_usage"; exit 0 ;; - *) echo "\$ac_cs_usage"; exit 1 ;; - esac -done - -ac_given_srcdir=$srcdir -ac_given_INSTALL="$INSTALL" - -trap 'rm -fr `echo "Makefile qt.h md/Makefile time/Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15 -EOF -cat >> $CONFIG_STATUS <<EOF - -# Protect against being on the right side of a sed subst in config.status. -sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g; - s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF -$ac_vpsub -$extrasub -s%@CFLAGS@%$CFLAGS%g -s%@CPPFLAGS@%$CPPFLAGS%g -s%@CXXFLAGS@%$CXXFLAGS%g -s%@DEFS@%$DEFS%g -s%@LDFLAGS@%$LDFLAGS%g -s%@LIBS@%$LIBS%g -s%@exec_prefix@%$exec_prefix%g -s%@prefix@%$prefix%g -s%@program_transform_name@%$program_transform_name%g -s%@bindir@%$bindir%g -s%@sbindir@%$sbindir%g -s%@libexecdir@%$libexecdir%g -s%@datadir@%$datadir%g -s%@sysconfdir@%$sysconfdir%g -s%@sharedstatedir@%$sharedstatedir%g -s%@localstatedir@%$localstatedir%g -s%@libdir@%$libdir%g -s%@includedir@%$includedir%g -s%@oldincludedir@%$oldincludedir%g -s%@infodir@%$infodir%g -s%@mandir@%$mandir%g -s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g -s%@INSTALL_DATA@%$INSTALL_DATA%g -s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g -s%@PACKAGE@%$PACKAGE%g -s%@VERSION@%$VERSION%g -s%@SET_MAKE@%$SET_MAKE%g -s%@module@%$module%g -s%@CC@%$CC%g -s%@CPP@%$CPP%g -s%@RANLIB@%$RANLIB%g -s%@host@%$host%g -s%@host_alias@%$host_alias%g -s%@host_cpu@%$host_cpu%g -s%@host_vendor@%$host_vendor%g -s%@host_os@%$host_os%g -s%@target_libs@%$target_libs%g -s%@qtmd_h@%$qtmd_h%g -s%@qtmdc_c@%$qtmdc_c%g -s%@qtmdc_o@%$qtmdc_o%g -s%@qtmds_s@%$qtmds_s%g -s%@qtmds_o@%$qtmds_o%g -s%@qtmdb_s@%$qtmdb_s%g - -CEOF -EOF - -cat >> $CONFIG_STATUS <<\EOF - -# Split the substitutions into bite-sized pieces for seds with -# small command number limits, like on Digital OSF/1 and HP-UX. -ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script. -ac_file=1 # Number of current file. -ac_beg=1 # First line for current file. -ac_end=$ac_max_sed_cmds # Line after last line for current file. -ac_more_lines=: -ac_sed_cmds="" -while $ac_more_lines; do - if test $ac_beg -gt 1; then - sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file - else - sed "${ac_end}q" conftest.subs > conftest.s$ac_file - fi - if test ! -s conftest.s$ac_file; then - ac_more_lines=false - rm -f conftest.s$ac_file - else - if test -z "$ac_sed_cmds"; then - ac_sed_cmds="sed -f conftest.s$ac_file" - else - ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file" - fi - ac_file=`expr $ac_file + 1` - ac_beg=$ac_end - ac_end=`expr $ac_end + $ac_max_sed_cmds` - fi -done -if test -z "$ac_sed_cmds"; then - ac_sed_cmds=cat -fi -EOF - -cat >> $CONFIG_STATUS <<EOF - -CONFIG_FILES=\${CONFIG_FILES-"Makefile qt.h md/Makefile time/Makefile"} -EOF -cat >> $CONFIG_STATUS <<\EOF -for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then - # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". - case "$ac_file" in - *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'` - ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; - *) ac_file_in="${ac_file}.in" ;; - esac - - # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories. - - # Remove last slash and all that follows it. Not all systems have dirname. - ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` - if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then - # The file is in a subdirectory. - test ! -d "$ac_dir" && mkdir "$ac_dir" - ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" - # A "../" for each directory in $ac_dir_suffix. - ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` - else - ac_dir_suffix= ac_dots= - fi - - case "$ac_given_srcdir" in - .) srcdir=. - if test -z "$ac_dots"; then top_srcdir=. - else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; - /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; - *) # Relative path. - srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" - top_srcdir="$ac_dots$ac_given_srcdir" ;; - esac - - case "$ac_given_INSTALL" in - [/$]*) INSTALL="$ac_given_INSTALL" ;; - *) INSTALL="$ac_dots$ac_given_INSTALL" ;; - esac - - echo creating "$ac_file" - rm -f "$ac_file" - configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." - case "$ac_file" in - *Makefile*) ac_comsub="1i\\ -# $configure_input" ;; - *) ac_comsub= ;; - esac - - ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"` - sed -e "$ac_comsub -s%@configure_input@%$configure_input%g -s%@srcdir@%$srcdir%g -s%@top_srcdir@%$top_srcdir%g -s%@INSTALL@%$INSTALL%g -" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file -fi; done -rm -f conftest.s* - -EOF -cat >> $CONFIG_STATUS <<EOF - -EOF -cat >> $CONFIG_STATUS <<\EOF - -exit 0 -EOF -chmod +x $CONFIG_STATUS -rm -fr confdefs* $ac_clean_files -test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 - diff --git a/qt/configure.in b/qt/configure.in deleted file mode 100644 index 1a235dbf3..000000000 --- a/qt/configure.in +++ /dev/null @@ -1,75 +0,0 @@ -AC_INIT(qt.c) -AM_INIT_GUILE_MODULE(qt) - -dnl Checks for programs. -AC_PROG_CC -AC_PROG_CPP -AC_PROG_RANLIB - -CY_AC_WITH_THREADS - -threads_enabled=false -if test "$cy_cv_threads_package" = COOP; then - threads_enabled=true -fi - -# Determine the host we are working on -AC_CANONICAL_HOST - -case "$host" in -i386-*-*|i486-*-*|i586-*-*) - qtmds_s=$srcdir/md/i386.s - qtmd_h=$srcdir/md/i386.h - qtmdc_c=$srcdir/md/null.c - ;; -mips-sgi-irix5*) - qtmds_s=$srcdir/md/mips-irix5.s - qtmd_h=$srcdir/md/mips.h - qtmdc_c=$srcdir/md/null.c - qtdmdb_s=$srcdir/md/mips_b.s - ;; -mips-*-*) - qtmds_s=$srcdir/md/mips.s - qtmd_h=$srcdir/md/mips.h - qtmdc_c=$srcdir/md/null.c - qtdmdb_s=$srcdir/md/mips_b.s - ;; -sparc-sun-solaris2.*) - qtmd_h=$srcdir/md/sparc.h - qtmdc_c=$srcdir/md/null.c - qtmds_s=$srcdir/md/sparc.s - qtdmdb_s=$srcdir/md/sparc_b.s - ;; -sparc-*-*) - qtmd_h=$srcdir/md/sparc.h - qtmdc_c=$srcdir/md/null.c - qtmds_s=$srcdir/md/_sparc.s - qtdmdb_s=$srcdir/md/_sparc_b.s - ;; -*) - echo "Unknown configuration; threads package disabled" - threads_enabled=false - ;; -esac - - -if $threads_enabled; then - target_libs=libqt.a -else - target_libs= -fi - -# Give the Makefile the names of the object files that will be -# generated by compiling $qtmdc_c and $qtmds_s. -qtmdc_o="`echo ${qtmdc_c} | sed -e 's:^.*/::' | sed -e 's:\.c$:\.o:'`" -qtmds_o="`echo ${qtmds_s} | sed -e 's:^.*/::' | sed -e 's:\.s$:\.o:'`" - -AC_SUBST(target_libs) -AC_SUBST(qtmd_h) -AC_SUBST(qtmdc_c) -AC_SUBST(qtmdc_o) -AC_SUBST(qtmds_s) -AC_SUBST(qtmds_o) -AC_SUBST(qtmdb_s) - -AC_OUTPUT(Makefile qt.h md/Makefile time/Makefile) diff --git a/qt/copyright.h b/qt/copyright.h deleted file mode 100644 index 8a2361f9e..000000000 --- a/qt/copyright.h +++ /dev/null @@ -1,12 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ diff --git a/qt/md/.cvsignore b/qt/md/.cvsignore deleted file mode 100644 index f3c7a7c5d..000000000 --- a/qt/md/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -Makefile diff --git a/qt/md/Makefile.am b/qt/md/Makefile.am deleted file mode 100644 index aae2b5904..000000000 --- a/qt/md/Makefile.am +++ /dev/null @@ -1,11 +0,0 @@ -## Process this file with automake to produce Makefile.in. - -AUTOMAKE_OPTIONS = foreign - -EXTRA_DIST = _sparc.s _sparc_b.s axp.1.Makefile axp.2.Makefile \ -axp.Makefile axp.README axp.c axp.h axp.s axp_b.s default.Makefile \ -hppa-cnx.Makefile hppa.Makefile hppa.h hppa.s hppa_b.s i386.README \ -i386.h i386.s i386_b.s ksr1.Makefile ksr1.h ksr1.s ksr1_b.s \ -m88k.Makefile m88k.c m88k.h m88k.s m88k_b.s mips-irix5.s mips.h mips.s \ -mips_b.s null.README null.c solaris.README sparc.h sparc.s sparc_b.s \ -vax.h vax.s vax_b.s diff --git a/qt/md/Makefile.in b/qt/md/Makefile.in deleted file mode 100644 index eace458d9..000000000 --- a/qt/md/Makefile.in +++ /dev/null @@ -1,154 +0,0 @@ -# Makefile.in generated automatically by automake 1.1l from Makefile.am - -# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. -# This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - - -SHELL = /bin/sh - -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -VPATH = @srcdir@ -prefix = @prefix@ -exec_prefix = @exec_prefix@ - -bindir = @bindir@ -sbindir = @sbindir@ -libexecdir = @libexecdir@ -datadir = @datadir@ -sysconfdir = @sysconfdir@ -sharedstatedir = @sharedstatedir@ -localstatedir = @localstatedir@ -libdir = @libdir@ -infodir = @infodir@ -mandir = @mandir@ -includedir = @includedir@ -oldincludedir = /usr/include - -pkgdatadir = $(datadir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ - -top_builddir = .. - -INSTALL = @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -transform = @program_transform_name@ -host_alias = @host_alias@ -host_triplet = @host@ -RANLIB = @RANLIB@ -module = @module@ -qtmd_h = @qtmd_h@ -CC = @CC@ -PACKAGE = @PACKAGE@ -VERSION = @VERSION@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -qtmds_o = @qtmds_o@ -qtmdc_o = @qtmdc_o@ -target_libs = @target_libs@ -qtmds_s = @qtmds_s@ -qtmdc_c = @qtmdc_c@ -qtmdb_s = @qtmdb_s@ - -AUTOMAKE_OPTIONS = foreign - -EXTRA_DIST = _sparc.s _sparc_b.s axp.1.Makefile axp.2.Makefile \ -axp.Makefile axp.README axp.c axp.h axp.s axp_b.s default.Makefile \ -hppa-cnx.Makefile hppa.Makefile hppa.h hppa.s hppa_b.s i386.README \ -i386.h i386.s i386_b.s ksr1.Makefile ksr1.h ksr1.s ksr1_b.s \ -m88k.Makefile m88k.c m88k.h m88k.s m88k_b.s mips-irix5.s mips.h mips.s \ -mips_b.s null.README null.c solaris.README sparc.h sparc.s sparc_b.s \ -vax.h vax.s vax_b.s -mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs -CONFIG_CLEAN_FILES = -DIST_COMMON = Makefile.am Makefile.in - - -DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \ - $(TEXINFOS) $(MANS) $(EXTRA_DIST) - -TAR = tar -default: all - -.SUFFIXES: -$(srcdir)/Makefile.in: Makefile.am $(top_srcdir)/configure.in $(ACLOCAL) - cd $(top_srcdir) && automake --foreign md/Makefile - -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES) - cd $(top_builddir) \ - && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= $(SHELL) ./config.status - -tags: TAGS -TAGS: - - -distdir = $(top_builddir)/$(PACKAGE)-$(VERSION)/$(subdir) - -subdir = md -distdir: $(DISTFILES) - @for file in $(DISTFILES); do \ - d=$(srcdir); \ - test -f $(distdir)/$$file \ - || ln $$d/$$file $(distdir)/$$file 2> /dev/null \ - || cp -p $$d/$$file $(distdir)/$$file; \ - done -info: -dvi: -check: all - $(MAKE) -installcheck: -install-exec: - $(NORMAL_INSTALL) - -install-data: - $(NORMAL_INSTALL) - -install: install-exec install-data all - @: - -uninstall: - -all: Makefile - -install-strip: - $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install -installdirs: - - -mostlyclean-generic: - test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) - -clean-generic: - test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) - -distclean-generic: - rm -f Makefile $(DISTCLEANFILES) - rm -f config.cache config.log stamp-h - test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -maintainer-clean-generic: - test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) - test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) -mostlyclean: mostlyclean-generic - -clean: clean-generic mostlyclean - -distclean: distclean-generic clean - rm -f config.status - -maintainer-clean: maintainer-clean-generic distclean - @echo "This command is intended for maintainers to use;" - @echo "it deletes files that may require special tools to rebuild." - -.PHONY: default tags distdir info dvi installcheck install-exec \ -install-data install uninstall all installdirs mostlyclean-generic \ -distclean-generic clean-generic maintainer-clean-generic clean \ -mostlyclean distclean maintainer-clean - - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff --git a/qt/md/_sparc.s b/qt/md/_sparc.s deleted file mode 100644 index 1d8adc77e..000000000 --- a/qt/md/_sparc.s +++ /dev/null @@ -1,142 +0,0 @@ -/* sparc.s -- assembly support for the `qt' thread building kit. */ - -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -/* #include <machine/trap.h> */ - - .text - .align 4 - .global _qt_blocki - .global _qt_block - .global _qt_abort - .global _qt_start - .global _qt_vstart - -/* Register assignment: -// %o0: incoming `helper' function to call after cswap -// also used as outgoing sp of old thread (qt_t *) -// %o1, %o2: -// parameters to `helper' function called after cswap -// %o3: sp of new thread -// %o5: tmp used to save old thread sp, while using %o0 -// to call `helper' f() after cswap. -// -// -// Aborting a thread is easy if there are no cached register window -// frames: just switch to the new stack and away we go. If there are -// cached register window frames they must all be written back to the -// old stack before we move to the new stack. If we fail to do the -// writeback then the old stack memory can be written with register -// window contents e.g., after the stack memory has been freed and -// reused. -// -// If you don't believe this, try setting the frame pointer to zero -// once we're on the new stack. This will not affect correctnes -// otherwise because the frame pointer will eventually get reloaded w/ -// the new thread's frame pointer. But it will be zero briefly before -// the reload. You will eventually (100,000 cswaps later on a small -// SPARC machine that I tried) get an illegal instruction trap from -// the kernel trying to flush a cached window to location 0x0. -// -// Solution: flush windows before switching stacks, which invalidates -// all the other register windows. We could do the trap -// conditionally: if we're in the lowest frame of a thread, the fp is -// zero already so we know there's nothing cached. But we expect most -// aborts will be done from a first function that does a `save', so we -// will rarely save anything and always pay the cost of testing to see -// if we should flush. -// -// All floating-point registers are caller-save, so this routine -// doesn't need to do anything to save and restore them. -// -// `qt_block' and `qt_blocki' return the same value as the value -// returned by the helper function. We get this ``for free'' -// since we don't touch the return value register between the -// return from the helper function and return from qt_block{,i}. -*/ - -_qt_block: -_qt_blocki: - sub %sp, 8, %sp /* Allocate save area for return pc. */ - st %o7, [%sp+64] /* Save return pc. */ -_qt_abort: - ta 0x03 /* Save locals and ins. */ - mov %sp, %o5 /* Remember old sp w/o chng ins/locals. */ - sub %o3, 64, %sp /* Allocate kwsa, switch stacks. */ - call %o0, 0 /* Call `helper' routine. */ - mov %o5, %o0 /* Pass old thread to qt_after_t() */ - /* .. along w/ args in %o1 & %o2. */ - - /* Restore callee-save regs. The kwsa - // is on this stack, so offset all - // loads by sizeof(kwsa), 64 bytes. - */ - ldd [%sp+ 0+64], %l0 - ldd [%sp+ 8+64], %l2 - ldd [%sp+16+64], %l4 - ldd [%sp+24+64], %l6 - ldd [%sp+32+64], %i0 - ldd [%sp+40+64], %i2 - ldd [%sp+48+64], %i4 - ldd [%sp+56+64], %i6 - ld [%sp+64+64], %o7 /* Restore return pc. */ - - retl /* Return to address in %o7. */ - add %sp, 72, %sp /* Deallocate kwsa, ret pc area. */ - - -/* The function calling conventions say there has to be a 1-word area -// in the caller's stack to hold a pointer to space for aggregate -// return values. It also says there should be a 6-word area to hold -// %o0..%o5 if the callee wants to save them (why? I don't know...) -// Round up to 8 words to maintain alignment. -// -// Parameter values were stored in callee-save regs and are moved to -// the parameter registers. -*/ -_qt_start: - mov %i1, %o0 /* `pu': Set up args to `only'. */ - mov %i2, %o1 /* `pt'. */ - mov %i4, %o2 /* `userf'. */ - call %i5, 0 /* Call client function. */ - sub %sp, 32, %sp /* Allocate 6-word callee space. */ - - call _qt_error, 0 /* `only' erroniously returned. */ - nop - - -/* Same comments as `_qt_start' about allocating rounded-up 7-word -// save areas. */ - -_qt_vstart: - sub %sp, 32, %sp /* Allocate 7-word callee space. */ - call %i5, 0 /* call `startup'. */ - mov %i2, %o0 /* .. with argument `pt'. */ - - add %sp, 32, %sp /* Use 7-word space in varargs. */ - ld [%sp+ 4+64], %o0 /* Load arg0 ... */ - ld [%sp+ 8+64], %o1 - ld [%sp+12+64], %o2 - ld [%sp+16+64], %o3 - ld [%sp+20+64], %o4 - call %i4, 0 /* Call `userf'. */ - ld [%sp+24+64], %o5 - - /* Use 6-word space in varargs. */ - mov %o0, %o1 /* Pass return value from userf */ - call %i3, 0 /* .. when call `cleanup. */ - mov %i2, %o0 /* .. along with argument `pt'. */ - - call _qt_error, 0 /* `cleanup' erroniously returned. */ - nop diff --git a/qt/md/_sparc_b.s b/qt/md/_sparc_b.s deleted file mode 100644 index cd26672d7..000000000 --- a/qt/md/_sparc_b.s +++ /dev/null @@ -1,106 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - - .globl _b_call_reg - .globl _b_call_imm - .globl _b_add - .globl _b_load - -_b_null: - retl - nop - -_b_call_reg: - sethi %hi(_b_null),%o4 - or %o4,%lo(_b_null),%o4 - add %o7,%g0, %o3 -L0: - call %o4 - nop - call %o4 - nop - call %o4 - nop - call %o4 - nop - call %o4 - nop - - subcc %o0,1,%o0 - bg L0 - nop - add %o3,%g0, %o7 - retl - nop - -_b_call_imm: - sethi %hi(_b_null),%o4 - or %o4,%lo(_b_null),%o4 - add %o7,%g0, %o3 -L1: - call _b_null - call _b_null - call _b_null - call _b_null - call _b_null - - subcc %o0,1,%o0 - bg L0 - nop - add %o3,%g0, %o7 - retl - nop - - -_b_add: - add %o0,%g0,%o1 - add %o0,%g0,%o2 - add %o0,%g0,%o3 - add %o0,%g0,%o4 -L2: - sub %o0,5,%o0 - sub %o1,5,%o1 - sub %o2,5,%o2 - sub %o3,5,%o3 - sub %o4,5,%o4 - - subcc %o0,5,%o0 - sub %o1,5,%o1 - sub %o2,5,%o2 - sub %o3,5,%o3 - sub %o4,5,%o4 - - bg L2 - nop - retl - nop - - -_b_load: - ld [%sp+ 0], %g0 -L3: - ld [%sp+ 4],%g0 - ld [%sp+ 8],%g0 - ld [%sp+12],%g0 - ld [%sp+16],%g0 - ld [%sp+20],%g0 - ld [%sp+24],%g0 - ld [%sp+28],%g0 - ld [%sp+32],%g0 - ld [%sp+36],%g0 - - subcc %o0,10,%o0 - bg L3 - ld [%sp+ 0],%g0 - retl - nop diff --git a/qt/md/axp.1.Makefile b/qt/md/axp.1.Makefile deleted file mode 100644 index 86ccd8f42..000000000 --- a/qt/md/axp.1.Makefile +++ /dev/null @@ -1,5 +0,0 @@ - -# -# Compiling for the DEC AXP (alpha) with GNU CC or version 1.x of OSF. -# -CC = cc -std1 -D__AXP__ -D__OSF1__ diff --git a/qt/md/axp.2.Makefile b/qt/md/axp.2.Makefile deleted file mode 100644 index 268636fc9..000000000 --- a/qt/md/axp.2.Makefile +++ /dev/null @@ -1,5 +0,0 @@ - -# -# Compiling for the DEC AXP (alpha) with GNU CC or version 2.x of OSF. -# -CC = cc -std1 -D__AXP__ -D__OSF2__ diff --git a/qt/md/axp.Makefile b/qt/md/axp.Makefile deleted file mode 100644 index 4e6d74da4..000000000 --- a/qt/md/axp.Makefile +++ /dev/null @@ -1,5 +0,0 @@ - -# -# GNU CC -# -CC = gcc -D__AXP__ diff --git a/qt/md/axp.README b/qt/md/axp.README deleted file mode 100644 index b6a705c07..000000000 --- a/qt/md/axp.README +++ /dev/null @@ -1,10 +0,0 @@ -The handling of varargs is platform-dependent. Assar Westerlund -stared at the problem for a while and deduces the following table: - -vers / compiler cc gcc ----------------------------------------------------------------------- -1.3 a0, offset __base, __offset -2.0 _a0, _offset __base, __offset - -The current code should handle both cc and gcc versions, provided -you configure for the correct compiler. diff --git a/qt/md/axp.c b/qt/md/axp.c deleted file mode 100644 index 26c15c0ea..000000000 --- a/qt/md/axp.c +++ /dev/null @@ -1,133 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -#include <stdarg.h> -#include "qt.h" - - -/* Varargs is harder on the AXP. Parameters are saved on the stack as - something like (stack grows down to low memory; low at bottom of - picture): - - | : - | arg6 - +--- - | iarg5 - | : - | iarg3 <-- va_list._a0 + va_list._offset - | : - | iarg0 <-- va_list._a0 - +--- - | farg5 - | : - | farg0 - +--- - - When some of the arguments have known type, there is no need to - save all of them in the struct. So, for example, if the routine is - called - - zork (int a0, float a1, int a2, ...) - { - va_list ap; - va_start (ap, a2); - qt_vargs (... &ap ...); - } - - then offset is set to 3 * 8 (8 === sizeof machine word) = 24. - - What this means for us is that the user's routine needs to be - called with an arg list where some of the words in the `any type' - parameter list have to be split and moved up in to the int/fp - region. - - Ways in which this can fail: - - The user might not know the size of the pushed arguments anyway. - - Structures have funny promotion rules. - - Probably lots of other things. - - All in all, we never promised varargs would work reliably. */ - - - -#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE) - -#define QT_VARGS_MD0(sp, vabytes) \ - ((qt_t *)(((char *)(sp)) - 6*2*8 - QT_STKROUNDUP(vabytes))) - -extern void qt_vstart(void); -#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_R26, qt_vstart)) - - -/* Different machines use different implementations for varargs. - Unfortunately, the code below ``looks in to'' the varargs - structure, `va_list', and thus depends on the conventions. - The following #defines try to deal with it but don't catch - everything. */ - -#ifdef __GNUC__ -#define _a0 __base -#define _offset __offset -#else -#ifdef __OSF1__ -#define _a0 a0 -#define _offset offset -#endif -#endif /* def __GNUC__ */ - - - struct qt_t * -qt_vargs (struct qt_t *qsp, int nbytes, struct va_list *vargs, - void *pt, qt_function_t *startup, - qt_function_t *vuserf, qt_function_t *cleanup) -{ - va_list ap; - int i; - int max; /* Maximum *words* of args to copy. */ - int tmove; /* *Words* of args moved typed->typed. */ - qt_word_t *sp; - - ap = *(va_list *)vargs; - qsp = QT_VARGS_MD0 (qsp, nbytes); - sp = (qt_word_t *)qsp; - - tmove = 6 - ap._offset/sizeof(qt_word_t); - - /* Copy from one typed area to the other. */ - for (i=0; i<tmove; ++i) { - /* Integer args: */ - sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i]; - /* Fp args: */ - sp[i] = ((qt_word_t *)(ap._a0 + ap._offset))[i-6]; - } - - max = nbytes/sizeof(qt_word_t); - - /* Copy from the untyped area to the typed area. Split each arg. - in to integer and floating-point save areas. */ - for (; i<6 && i<max; ++i) { - sp[i] = sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i]; - } - - /* Copy from the untyped area to the other untyped area. */ - for (; i<max; ++i) { - sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i]; - } - - QT_VARGS_MD1 (QT_VADJ(sp)); - QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt); - QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup); - QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf); - QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup); - return ((qt_t *)QT_VADJ(sp)); -} diff --git a/qt/md/axp.h b/qt/md/axp.h deleted file mode 100644 index ff951a0d3..000000000 --- a/qt/md/axp.h +++ /dev/null @@ -1,160 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -#ifndef QT_AXP_H -#define QT_AXP_H - -#define QT_GROW_DOWN - -typedef unsigned long qt_word_t; - - -/* Stack layout on the Alpha: - - Integer: - - Caller-save: r0..r8, r22..r25, r27..r29 - argument/caller-save: r16..r21 - callee-save: r9..r15 - return pc *callee-save*: r26 - stack pointer: r30 - zero: r31 - - Floating-point: - - Caller-save: f0..f1, f10..f15 - argument/caller-save: f16..f21, f22..f30 - callee-save: f2..f9 - zero: f31 - - Non-varargs: - - +--- - | padding - | f9 - | f8 - | f7 - | f6 - | f5 - | f4 - | f3 - | f2 - | r26 - +--- - | padding - | r29 - | r15 - | r14 - | r13 - | r12 on startup === `only' - | r11 on startup === `userf' - | r10 on startup === `qt' - | r9 on startup === `qu' - | r26 on startup === qt_start <--- qt.sp - +--- - - Conventions for varargs startup: - - | : - | arg6 - | iarg5 - | : - | iarg0 - | farg5 - | : - | farg0 - +--- - | padding - | r29 - | r15 - | r14 - | r13 - | r12 on startup === `startup' - | r11 on startup === `vuserf' - | r10 on startup === `cleanup' - | r9 on startup === `qt' - | r26 on startup === qt_vstart <--- qt.sp - +--- - - Note: this is a pretty cheap/sleazy way to get things going, - but ``there must be a better way.'' For instance, some varargs - parameters could be loaded in to integer registers, or the return - address could be stored on top of the stack. */ - - -/* Stack must be 16-byte aligned. */ -#define QT_STKALIGN (16) - -/* How much space is allocated to hold all the crud for - initialization: 7 registers times 8 bytes/register. */ - -#define QT_STKBASE (10 * 8) -#define QT_VSTKBASE QT_STKBASE - - -/* Offsets of various registers. */ -#define QT_R26 0 -#define QT_R9 1 -#define QT_R10 2 -#define QT_R11 3 -#define QT_R12 4 - - -/* When a never-before-run thread is restored, the return pc points - to a fragment of code that starts the thread running. For - non-vargs functions, it just calls the client's `only' function. - For varargs functions, it calls the startup, user, and cleanup - functions. - - The varargs startup routine always reads 12 8-byte arguments from - the stack. If fewer argumets were pushed, the startup routine - would read off the top of the stack. To prevent errors we always - allocate enough space. When there are fewer args, the preallocated - words are simply wasted. */ - -extern void qt_start(void); -#define QT_ARGS_MD(sp) (QT_SPUT (sp, QT_R26, qt_start)) - - -/* The AXP uses a struct for `va_list', so pass a pointer to the - struct. This may break some uses of `QT_VARGS', but then we never - claimed it was totally portable. */ - -typedef void (qt_function_t)(void); - -struct qt_t; -struct va_list; -extern struct qt_t *qt_vargs (struct qt_t *sp, int nbytes, - struct va_list *vargs, void *pt, - qt_function_t *startup, - qt_function_t *vuserf, - qt_function_t *cleanup); - -#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \ - (qt_vargs (sp, nbytes, (struct va_list *)(&(vargs)), pt, \ - (qt_function_t *) startup, (qt_function_t *)vuserf, \ - (qt_function_t *)cleanup)); - - -/* The *index* (positive offset) of where to put each value. */ -#define QT_ONLY_INDEX (QT_R12) -#define QT_USER_INDEX (QT_R11) -#define QT_ARGT_INDEX (QT_R10) -#define QT_ARGU_INDEX (QT_R9) - -#define QT_VCLEANUP_INDEX (QT_R10) -#define QT_VUSERF_INDEX (QT_R11) -#define QT_VSTARTUP_INDEX (QT_R12) -#define QT_VARGT_INDEX (QT_R9) - -#endif /* ndef QT_AXP_H */ diff --git a/qt/md/axp.s b/qt/md/axp.s deleted file mode 100644 index a84aab2cc..000000000 --- a/qt/md/axp.s +++ /dev/null @@ -1,160 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -/* axp.s -- assembly support. */ - - .text - .align 4 - .file 2 "axp.s" - - .globl qt_block - .globl qt_blocki - .globl qt_abort - .globl qt_start - .globl qt_vstart - - /* - ** $16: ptr to function to call once curr is suspended - ** and control is on r19's stack. - ** $17: 1'th arg to (*$16)(...). - ** $18: 2'th arg to (*$16)(...). - ** $19: sp of thread to resume. - ** - ** The helper routine returns a value that is passed on as the - ** return value from the blocking routine. Since we don't - ** touch r0 between the helper's return and the end of - ** function, we get this behavior for free. - */ - - .ent qt_blocki -qt_blocki: - subq $30,80, $30 /* Allocate save area. */ - stq $26, 0($30) /* Save registers. */ - stq $9, 8($30) - stq $10,16($30) - stq $11,24($30) - stq $12,32($30) - stq $13,40($30) - stq $14,48($30) - stq $15,56($30) - stq $29,64($30) - .end qt_blocki - .ent qt_abort -qt_abort: - addq $16,$31, $27 /* Put argument function in PV. */ - addq $30,$31, $16 /* Save stack ptr in outgoing arg. */ - addq $19,$31, $30 /* Set new stack pointer. */ - jsr $26,($27),0 /* Call helper function. */ - - ldq $26, 0($30) /* Restore registers. */ - ldq $9, 8($30) - ldq $10,16($30) - ldq $11,24($30) - ldq $12,32($30) - ldq $13,40($30) - ldq $14,48($30) - ldq $15,56($30) - ldq $29,64($30) - - addq $30,80, $30 /* Deallocate save area. */ - ret $31,($26),1 /* Return, predict===RET. */ - .end qt_abort - - - /* - ** Non-varargs thread startup. - */ - .ent qt_start -qt_start: - addq $9,$31, $16 /* Load up `qu'. */ - addq $10,$31, $17 /* ... user function's `pt'. */ - addq $11,$31, $18 /* ... user function's `userf'. */ - addq $12,$31, $27 /* ... set procedure value to `only'. */ - jsr $26,($27),0 /* Call `only'. */ - - jsr $26,qt_error /* `only' erroniously returned. */ - .end qt_start - - - .ent qt_vstart: -qt_vstart: - /* Call startup function. */ - addq $9,$31, $16 /* Arg0 to `startup'. */ - addq $12,$31, $27 /* Set procedure value. */ - jsr $26,($27),0 /* Call `startup'. */ - - /* Call user function. */ - ldt $f16, 0($30) /* Load fp arg regs. */ - ldt $f17, 8($30) - ldt $f18,16($30) - ldt $f19,24($30) - ldt $f20,32($30) - ldt $f21,40($30) - ldq $16,48($30) /* And integer arg regs. */ - ldq $17,56($30) - ldq $18,64($30) - ldq $19,72($30) - ldq $20,80($30) - ldq $21,88($30) - addq $30,96 $30 /* Pop 6*2*8 saved arg regs. */ - addq $11,$31, $27 /* Set procedure value. */ - jsr $26,($27),0 /* Call `vuserf'. */ - - /* Call cleanup. */ - addq $9,$31, $16 /* Arg0 to `cleanup'. */ - addq $0,$31, $17 /* Users's return value is arg1. */ - addq $10,$31, $27 /* Set procedure value. */ - jsr $26,($27),0 /* Call `cleanup'. */ - - jsr $26,qt_error /* Cleanup erroniously returned. */ - .end qt_start - - - /* - ** Save calle-save floating-point regs $f2..$f9. - ** Also save return pc from whomever called us. - ** - ** Return value from `qt_block' is the same as the return from - ** `qt_blocki'. We get that for free since we don't touch $0 - ** between the return from `qt_blocki' and the return from - ** `qt_block'. - */ - .ent qt_block -qt_block: - subq $30,80, $30 /* Allocate a save space. */ - stq $26, 0($30) /* Save registers. */ - stt $f2, 8($30) - stt $f3,16($30) - stt $f4,24($30) - stt $f5,32($30) - stt $f6,40($30) - stt $f7,48($30) - stt $f8,56($30) - stt $f9,64($30) - - jsr $26,qt_blocki /* Call helper. */ - /* .. who will also restore $gp. */ - - ldq $26, 0($30) /* restore registers. */ - ldt $f2, 8($30) - ldt $f3,16($30) - ldt $f4,24($30) - ldt $f5,32($30) - ldt $f6,40($30) - ldt $f7,48($30) - ldt $f8,56($30) - ldt $f9,64($30) - - addq $30,80, $30 /* Deallcate save space. */ - ret $31,($26),1 /* Return, predict===RET. */ - .end qt_block diff --git a/qt/md/axp_b.s b/qt/md/axp_b.s deleted file mode 100644 index 60be726ff..000000000 --- a/qt/md/axp_b.s +++ /dev/null @@ -1,111 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - - .text - .globl b_call_reg - .globl b_call_imm - .globl b_add - .globl b_load - - .ent b_null -b_null: - ret $31,($18),1 - .end b_null - - .ent b_call_reg -b_call_reg: - lda $27,b_null -$L0: - jsr $18,($27) - jsr $18,($27) - jsr $18,($27) - jsr $18,($27) - jsr $18,($27) - - jsr $18,($27) - jsr $18,($27) - jsr $18,($27) - jsr $18,($27) - jsr $18,($27) - - subq $16,1,$16 - bgt $16,$L0 - - ret $31,($26),1 - .end - - - .ent b_call_imm -b_call_imm: -$L1: - jsr $18,b_null - jsr $18,b_null - jsr $18,b_null - jsr $18,b_null - jsr $18,b_null - - jsr $18,b_null - jsr $18,b_null - jsr $18,b_null - jsr $18,b_null - jsr $18,b_null - - subq $16,1,$16 - bgt $16,$L1 - - ret $31,($26),1 - .end - - - .ent b_add -b_add: -$L2: - addq $31,$31,$31 - addq $31,$31,$31 - addq $31,$31,$31 - addq $31,$31,$31 - addq $31,$31,$31 - - addq $31,$31,$31 - addq $31,$31,$31 - addq $31,$31,$31 - addq $31,$31,$31 - addq $31,$31,$31 - - subq $16,1,$16 - bgt $16,$L2 - - ret $31,($26),1 - .end - - - .ent b_load -b_load: -$L3: - ldq $31,0($30) - ldq $31,8($30) - ldq $31,16($30) - ldq $31,24($30) - ldq $31,32($30) - - ldq $31,0($30) - ldq $31,8($30) - ldq $31,16($30) - ldq $31,24($30) - ldq $31,32($30) - - subq $16,1,$16 - bgt $16,$L3 - - ret $31,($26),1 - .end diff --git a/qt/md/default.Makefile b/qt/md/default.Makefile deleted file mode 100644 index e240ca270..000000000 --- a/qt/md/default.Makefile +++ /dev/null @@ -1,6 +0,0 @@ - -# -# `Normal' configuration. -# -CC = gcc -ansi -Wall -pedantic - diff --git a/qt/md/hppa-cnx.Makefile b/qt/md/hppa-cnx.Makefile deleted file mode 100644 index bff257d9f..000000000 --- a/qt/md/hppa-cnx.Makefile +++ /dev/null @@ -1,9 +0,0 @@ -# This file (cnx_spp.Makefile) is part of the port of QuickThreads for -# PA-RISC 1.1 architecture on a Convex SPP. This file is a machine dependent -# makefile for QuickThreads. It was written in 1994 by Uwe Reder -# (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems -# Department (IMMD4) at the University of Erlangen/Nuernberg Germany. - -# `Normal' configuration. - -CC = /usr/convex/bin/cc diff --git a/qt/md/hppa.Makefile b/qt/md/hppa.Makefile deleted file mode 100644 index a15e28c99..000000000 --- a/qt/md/hppa.Makefile +++ /dev/null @@ -1,9 +0,0 @@ -# This file (pa-risc.Makefile) is part of the port of QuickThreads for -# PA-RISC 1.1 architecture. This file is a machine dependent makefile -# for QuickThreads. It was written in 1994 by Uwe Reder -# (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems -# Department (IMMD4) at the University of Erlangen/Nuernberg Germany. - -# `Normal' configuration. - -CC = cc -Aa diff --git a/qt/md/hppa.h b/qt/md/hppa.h deleted file mode 100644 index 0df98de88..000000000 --- a/qt/md/hppa.h +++ /dev/null @@ -1,194 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -/* - * This file (pa-risc.h) is part of the port of QuickThreads for the - * PA-RISC 1.1 architecture. This file is a machine dependent header - * file. It was written in 1994 by Uwe Reder - * (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems - * Department (IMMD4) at the University of Erlangen/Nuernberg Germany. - */ - - -#ifndef QT_PA_RISC_H -#define QT_PA_RISC_H - -#include <qt.h> - -/* size of an integer-register (32 bit) */ -typedef unsigned long qt_word_t; - -/* PA-RISC's stack grows up */ -#define QT_GROW_UP - -/* Stack layout on PA-RISC according to PA-RISC Procedure Calling Conventions: - - Callee-save registers are: gr3-gr18, fr12-fr21. - Also save gr2, return pointer. - - +--- - | fr12 Each floating register is a double word (8 bytes). - | fr13 Floating registers are only saved if `qt_block' is - | fr14 called, in which case it saves the floating-point - | fr15 registers then calls `qt_blocki' to save the integer - | fr16 registers. - | fr17 - | fr18 - | fr19 - | fr20 - | fr21 - | <arg word 3> fixed arguments (must be allocated; may remain unused) - | <arg word 2> - | <arg word 1> - | <arg word 0> - | <LPT> frame marker - | <LPT'> - | <RP'> - | <Current RP> - | <Static Link> - | <Clean Up> - | <RP''> - | <Previous SP> - +--- - | gr3 word each (4 bytes) - | gr4 - | gr5 - | gr6 - | gr7 - | gr8 - | gr9 - | gr10 - | gr11 - | gr12 - | gr13 - | gr14 - | gr15 - | gr16 - | gr17 - | gr18 - | <16 bytes filled in (sp has to be 64-bytes aligned)> - | <arg word 3> fixed arguments (must be allocated; may remain unused) - | <arg word 2> - | <arg word 1> - | <arg word 0> - | <LPT> frame marker - | <LPT'> - | <RP'> - | <Current RP> - | <Static Link> - | <Clean Up> - | <RP''> - | <Previous SP> - +--- <--- sp -*/ - -/* When a never-before-run thread is restored, the return pc points - to a fragment of code that starts the thread running. For - non-vargs functions, it just calls the client's `only' function. - For varargs functions, it calls the startup, user, and cleanup - functions. */ - -/* Note: Procedue Labels on PA-RISC - - <--2--><-------28---------><1-><1-> - ----------------------------------- - | SID | Adress Part | L | X | - ----------------------------------- - - On HP-UX the L field is used to flag wheather the procedure - label (plabel) is a pointer to an LT entry or to the entry point - of the procedure (PA-RISC Procedure Calling Conventions Reference - Manual, 5.3.2 Procedure Labels and Dynamic Calls). */ - -#define QT_PA_RISC_READ_PLABEL(plabel) \ - ( (((int)plabel) & 2) ? \ - ( (*((int *)(((int)plabel) & 0xfffffffc)))) : ((int)plabel) ) - -/* Stack must be 64 bytes aligned. */ -#define QT_STKALIGN (64) - -/* Internal helper for putting stuff on stack (negative index!). */ -#define QT_SPUT(top, at, val) \ - (((qt_word_t *)(top))[-(at)] = (qt_word_t)(val)) - -/* Offsets of various registers which are modified on the stack. - rp (return-pointer) has to be stored in the frame-marker-area - of the "older" stack-segment. */ - -#define QT_crp (12+4+16+5) -#define QT_15 (12+4+4) -#define QT_16 (12+4+3) -#define QT_17 (12+4+2) -#define QT_18 (12+4+1) - - -/** This stuff is for NON-VARARGS. **/ - -/* Stack looks like this (2 stack frames): - - <--- 64-bytes aligned --><------- 64-bytes aligned ------------> - | || | - <--16--><------48-------><----16*4-----><--16-><------48-------> - || | || | | || - ||filler|arg|frame-marker||register-save|filler|arg|frame-marker|| - ------------------------------------------------------------------ - */ - -#define QT_STKBASE (16+48+(16*sizeof(qt_word_t))+16+48) - -/* The index, relative to sp, of where to put each value. */ -#define QT_ONLY_INDEX (QT_15) -#define QT_USER_INDEX (QT_16) -#define QT_ARGT_INDEX (QT_17) -#define QT_ARGU_INDEX (QT_18) - -extern void qt_start(void); -#define QT_ARGS_MD(sp) \ - (QT_SPUT (sp, QT_crp, QT_PA_RISC_READ_PLABEL(qt_start))) - - -/** This is for VARARGS. **/ - -#define QT_VARGS_DEFAULT - -/* Stack looks like this (2 stack frames): - - <------ 64-bytes aligned -------><--------- 64-bytes aligned ----------> - | || | - <---?--><--?---><16><----32-----><----16*4-----><-16--><16><----32-----> - || | | | || | | | || - ||filler|varargs|arg|frame-marker||register-save|filler|arg|frame-marker|| - -------------------------------------------------------------------------- - */ - -/* Sp is moved to the end of the first stack frame. */ -#define QT_VARGS_MD0(sp, vasize) \ - ((qt_t *)(((char *)sp) + QT_STKROUNDUP(vasize + 4*4 + 32))) - -/* To reach the arguments from the end of the first stack frame use 32 - as a negative adjustment. */ -#define QT_VARGS_ADJUST(sp) ((qt_t *)(((char *)sp) - 32)) - -/* Offset to reach the end of the second stack frame. */ -#define QT_VSTKBASE ((16*sizeof(qt_word_t)) + 16 + 4*4 + 32) - -extern void qt_vstart(void); -#define QT_VARGS_MD1(sp) \ - (QT_SPUT (sp, QT_crp, QT_PA_RISC_READ_PLABEL(qt_vstart))) - -#define QT_VARGT_INDEX (QT_15) -#define QT_VSTARTUP_INDEX (QT_16) -#define QT_VUSERF_INDEX (QT_17) -#define QT_VCLEANUP_INDEX (QT_18) - -#endif /* ndef QT_PA_RISC_H */ diff --git a/qt/md/hppa.s b/qt/md/hppa.s deleted file mode 100644 index 84d8e875b..000000000 --- a/qt/md/hppa.s +++ /dev/null @@ -1,237 +0,0 @@ -; pa-risc.s -- assembly support. - -; QuickThreads -- Threads-building toolkit. -; Copyright (c) 1993 by David Keppel -; -; Permission to use, copy, modify and distribute this software and -; its documentation for any purpose and without fee is hereby -; granted, provided that the above copyright notice and this notice -; appear in all copies. This software is provided as a -; proof-of-concept and for demonstration purposes; there is no -; representation about the suitability of this software for any -; purpose. - -; This file (pa-risc.s) is part of the port of QuickThreads for -; PA-RISC 1.1 architecture. This file implements context switches -; and thread startup. It was written in 1994 by Uwe Reder -; (`uereder@cip.informatik.uni-erlangen.de') for the Operating -; Systems Department (IMMD4) at the University of Erlangen/Nuernberg -; Germany. - - -; Callee saves general registers gr3..gr18, -; floating-point registers fr12..fr21. - - .CODE - - .IMPORT $$dyncall, MILLICODE - .IMPORT qt_error, CODE - - .EXPORT qt_blocki, ENTRY - .EXPORT qt_block, ENTRY - .EXPORT qt_abort, ENTRY - .EXPORT qt_start, ENTRY - .EXPORT qt_vstart, ENTRY - - -; arg0: ptr to function (helper) to call once curr is suspended -; and control is on arg3's stack. -; arg1: 1'th arg to *arg0. -; arg2: 2'th arg to *arg0. -; arg3: sp of new thread. - -qt_blocki - .PROC - .CALLINFO CALLER, FRAME=0, SAVE_RP, ENTRY_GR=18 - .ENTRY - - stw %rp,-20(%sp) ; save rp to old frame-marker - - stwm %r3,128(%sp) ; save callee-saves general registers - stw %r4,-124(%sp) - stw %r5,-120(%sp) - stw %r6,-116(%sp) - stw %r7,-112(%sp) - stw %r8,-108(%sp) - stw %r9,-104(%sp) - stw %r10,-100(%sp) - stw %r11,-96(%sp) - stw %r12,-92(%sp) - stw %r13,-88(%sp) - stw %r14,-84(%sp) - stw %r15,-80(%sp) - stw %r16,-76(%sp) - stw %r17,-72(%sp) - stw %r18,-68(%sp) - -qt_abort - copy %arg0,%r22 ; helper to be called by $$dyncall - copy %sp,%arg0 ; pass current sp as arg0 to helper - copy %arg3,%sp ; set new sp - - .CALL - bl $$dyncall,%mrp ; call helper - copy %mrp,%rp - - ldw -68(%sp),%r18 ; restore general registers - ldw -72(%sp),%r17 - ldw -76(%sp),%r16 - ldw -80(%sp),%r15 - ldw -84(%sp),%r14 - ldw -88(%sp),%r13 - ldw -92(%sp),%r12 - ldw -96(%sp),%r11 - ldw -100(%sp),%r10 - ldw -104(%sp),%r9 - ldw -108(%sp),%r8 - ldw -112(%sp),%r7 - ldw -116(%sp),%r6 - ldw -120(%sp),%r5 - ldw -124(%sp),%r4 - - ldw -148(%sp),%rp ; restore return-pointer - - bv %r0(%rp) ; return to caller - ldwm -128(%sp),%r3 - - .EXIT - .PROCEND - - -qt_block - .PROC - .CALLINFO CALLER, FRAME=0, SAVE_RP, ENTRY_FR=21 - .ENTRY - - stw %rp,-20(%sp) ; save rp to old frame-marker - - fstds,ma %fr12,8(%sp) ; save callee-saves float registers - fstds,ma %fr13,8(%sp) - fstds,ma %fr14,8(%sp) - fstds,ma %fr15,8(%sp) - fstds,ma %fr16,8(%sp) - fstds,ma %fr17,8(%sp) - fstds,ma %fr18,8(%sp) - fstds,ma %fr19,8(%sp) - fstds,ma %fr20,8(%sp) - fstds,ma %fr21,8(%sp) - - .CALL - bl qt_blocki,%rp - ldo 48(%sp),%sp - - ldo -48(%sp),%sp - - fldds,mb -8(%sp),%fr21 ; restore callee-saves float registers - fldds,mb -8(%sp),%fr20 - fldds,mb -8(%sp),%fr19 - fldds,mb -8(%sp),%fr18 - fldds,mb -8(%sp),%fr17 - fldds,mb -8(%sp),%fr16 - fldds,mb -8(%sp),%fr15 - fldds,mb -8(%sp),%fr14 - fldds,mb -8(%sp),%fr13 - - ldw -28(%sp),%rp ; restore return-pointer - - bv %r0(%rp) ; return to caller. - fldds,mb -8(%sp),%fr12 - - .EXIT - .PROCEND - - -qt_start - .PROC - .CALLINFO CALLER, FRAME=0 - .ENTRY - - copy %r18,%arg0 ; set user arg `pu'. - copy %r17,%arg1 ; ... user function pt. - copy %r16,%arg2 ; ... user function userf. - ; %r22 is a caller-saves register - copy %r15,%r22 ; function to be called by $$dyncall - - .CALL ; in=%r22 - bl $$dyncall,%mrp ; call `only'. - copy %mrp,%rp - - bl,n qt_error,%r0 ; `only' erroniously returned. - - .EXIT - .PROCEND - - -; Varargs -; -; First, call `startup' with the `pt' argument. -; -; Next, call the user's function with all arguments. -; We don't know whether arguments are integers, 32-bit floating-points or -; even 64-bit floating-points, so we reload all the registers, possibly -; with garbage arguments. The thread creator provided non-garbage for -; the arguments that the callee actually uses, so the callee never gets -; garbage. -; -; -48 -44 -40 -36 -32 -; | arg3 | arg2 | arg1 | arg0 | -; ----------------------------- -; integers: arg3 arg2 arg1 arg0 -; 32-bit fps: farg3 farg2 farg1 farg0 -; 64-bit fps: <---farg3--> <---farg1--> -; -; Finally, call `cleanup' with the `pt' argument and with the return value -; from the user's function. It is an error for `cleanup' to return. - -qt_vstart - .PROC - .CALLINFO CALLER, FRAME=0 - .ENTRY - - ; Because the startup function may damage the fixed arguments - ; on the stack (PA-RISC Procedure Calling Conventions Reference - ; Manual, 2.4 Fixed Arguments Area), we allocate a seperate - ; stack frame for it. - ldo 64(%sp),%sp - - ; call: void startup(void *pt) - - copy %r15,%arg0 ; `pt' is arg0 to `startup'. - copy %r16,%r22 - .CALL - bl $$dyncall,%mrp ; Call `startup'. - copy %mrp,%rp - - ldo -64(%sp),%sp - - ; call: void *qt_vuserf_t(...) - - ldw -36(%sp),%arg0 ; Load args to integer registers. - ldw -40(%sp),%arg1 - ldw -44(%sp),%arg2 - ldw -48(%sp),%arg3 - ; Index of fld[w|d]s only ranges from -16 to 15, so we - ; take r22 to be our new base register. - ldo -32(%sp),%r22 - fldws -4(%r22),%farg0 ; Load args to floating-point registers. - fldds -8(%r22),%farg1 - fldws -12(%r22),%farg2 - fldds -16(%r22),%farg3 - copy %r17,%r22 - .CALL - bl $$dyncall,%mrp ; Call `userf'. - copy %mrp,%rp - - ; call: void cleanup(void *pt, void *vuserf_return) - - copy %r15,%arg0 ; `pt' is arg0 to `cleanup'. - copy %ret0,%arg1 ; Return-value is arg1 to `cleanup'. - copy %r18,%r22 - .CALL - bl $$dyncall,%mrp ; Call `cleanup'. - copy %mrp,%rp - - bl,n qt_error,%r0 - - .EXIT - .PROCEND diff --git a/qt/md/hppa_b.s b/qt/md/hppa_b.s deleted file mode 100644 index 1b1e8264e..000000000 --- a/qt/md/hppa_b.s +++ /dev/null @@ -1,203 +0,0 @@ -; QuickThreads -- Threads-building toolkit. -; Copyright (c) 1993 by David Keppel - -; Permission to use, copy, modify and distribute this software and -; its documentation for any purpose and without fee is hereby -; granted, provided that the above copyright notice and this notice -; appear in all copies. This software is provided as a -; proof-of-concept and for demonstration purposes; there is no -; representation about the suitability of this software for any -; purpose. - -; This file (pa-risc_b.s) is part of the port of QuickThreads for -; PA-RISC 1.1 architecture. It contains assembly-level support for -; raw processor performance measurement. It was written in 1994 by -; Uwe Reder (`uereder@cip.informatik.uni-erlangen.de') -; for the Operating Systems Department (IMMD4) at the -; University of Erlangen/Nuernberg Germany. - - -; Note that the number of instructions in the measurement-loops, differ -; from implementation to implementation. I took eight instructions in a loop -; for every test (execute eight instructions and loop to the start). - - .CODE - - .IMPORT $global$,DATA - .IMPORT $$dyncall,MILLICODE - .EXPORT b_call_reg - .EXPORT b_call_imm - .EXPORT b_add - .EXPORT b_load - -; Just do nothing, only return to caller. This procedure is called by -; `b_call_reg' and `b_call_imm'. - -b_null - .PROC - .CALLINFO NO_CALLS, FRAME=0 - .ENTRY - - bv,n %r0(%rp) ; just return - - .EXIT - .PROCEND - -; Call the procedure `b_null' with function pointer in a register. - -b_call_reg - .PROC - .CALLINFO CALLER, FRAME=0 - .ENTRY - - stwm %r3,64(%sp) ; store r3 (may be used by caller) - stw %rp,-20(%sp) ; save return-pointer to frame-marker - - addil LR'to_call-$global$,%r27 - ldw RR'to_call-$global$(%r1),%r3 - -_loop0 - copy %r3,%r22 ; copy the procedure label to r22, ... - .CALL ; ...this is the input to $$dyncall - bl $$dyncall,%mrp ; call $$dyncall (millicode function) - copy %mrp,%rp ; remember the return-pointer - - copy %r3,%r22 - .CALL - bl $$dyncall,%mrp - copy %mrp,%rp - - copy %r3,%r22 - .CALL - bl $$dyncall,%mrp - copy %mrp,%rp - - copy %r3,%r22 - .CALL - bl $$dyncall,%mrp - copy %mrp,%rp - - copy %r3,%r22 - .CALL - bl $$dyncall,%mrp - copy %mrp,%rp - - copy %r3,%r22 - .CALL - bl $$dyncall,%mrp - copy %mrp,%rp - - copy %r3,%r22 - .CALL - bl $$dyncall,%mrp - copy %mrp,%rp - - copy %r3,%r22 - .CALL - bl $$dyncall,%mrp - copy %mrp,%rp - - addibf,<= -8,%arg0,_loop0 ; decrement counter by 8 and loop - nop - - ldw -20(%sp),%rp ; restore return-pointer - bv %r0(%rp) ; return to caller - ldwm -64(%sp),%r3 ; resore r3 and remove stack frame - - .EXIT - .PROCEND - -; Call the procedure `b_null' immediate. - -b_call_imm - .PROC - .CALLINFO CALLER, FRAME=0, SAVE_RP - .ENTRY - - ldo 64(%sp),%sp ; caller needs a stack-frame - stw %rp,-20(%sp) ; save return-pointer to frame-marker - -_loop1 - bl b_null,%rp ; call `b_null' immediate (8 times) - nop - bl b_null,%rp - nop - bl b_null,%rp - nop - bl b_null,%rp - nop - bl b_null,%rp - nop - bl b_null,%rp - nop - bl b_null,%rp - nop - bl b_null,%rp - nop - - addibf,<= -8,%arg0,_loop1 ; decrement counter by 8 and loop - nop - - ldw -20(%sp),%rp ; restore return-pointer - bv %r0(%rp) ; return to caller - ldo -64(%sp),%sp ; remove stack-frame - - .EXIT - .PROCEND - -; Copy register-to-register. -; On PA-RISC this is implemented with an `or'. -; The `or' is hidden by a pseudo-operation called `copy'. - -b_add - .PROC - .CALLINFO NO_CALLS, FRAME=0 - .ENTRY - -_loop2 - copy %r19,%r20 ; copy register-to-register - copy %r20,%r21 ; use caller-saves registers - copy %r21,%r22 - copy %r22,%r21 - copy %r21,%r20 - copy %r20,%r19 - copy %r19,%r20 - copy %r20,%r21 - - addibf,<= -8,%arg0,_loop2 ; decrement counter by 8 and loop - nop - - bv,n %r0(%rp) - - .EXIT - .PROCEND - -; Load memory to a register. - -b_load - .PROC - .CALLINFO NO_CALLS, FRAME=0 - .ENTRY - -_loop3 - ldw -4(%sp),%r22 ; load data from frame-marker - ldw -8(%sp),%r22 ; use a caller-saves register - ldw -12(%sp),%r22 - ldw -16(%sp),%r22 - ldw -20(%sp),%r22 - ldw -24(%sp),%r22 - ldw -28(%sp),%r22 - ldw -32(%sp),%r22 - - addibf,<= -8,%arg0,_loop3 ; decrement counter by 8 and loop - nop - - bv,n %r0(%rp) - - .EXIT - .PROCEND - - - .ALIGN 8 -to_call - .WORD b_null diff --git a/qt/md/i386.README b/qt/md/i386.README deleted file mode 100644 index 8ffb92198..000000000 --- a/qt/md/i386.README +++ /dev/null @@ -1,7 +0,0 @@ -Note that some machines want labels to have leading underscores, -while others (e.g. System V) do not. Thus, several labels appear -duplicated except for the leading underscore, e.g. - - _qt_cswap: - qt_cswap: - diff --git a/qt/md/i386.h b/qt/md/i386.h deleted file mode 100644 index 158fe2703..000000000 --- a/qt/md/i386.h +++ /dev/null @@ -1,120 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -#ifndef QT_386_H -#define QT_386_H - -typedef unsigned long qt_word_t; - -/* Thread's initial stack layout on the i386: - - non-varargs: - - +--- - | arg[2] === `userf' on startup - | arg[1] === `pt' on startup - | arg[0] === `pu' on startup - +--- - | ret pc === qt_error - +--- - | ret pc === `only' on startup - +--- - | %ebp - | %esi - | %edi - | %ebx <--- qt_t.sp - +--- - - When a non-varargs thread is started, it ``returns'' directly to - the client's `only' function. - - varargs: - - +--- - | arg[n-1] - | .. - | arg[0] - +--- - | ret pc === `qt_vstart' - +--- - | %ebp === `startup' - | %esi === `cleanup' - | %edi === `pt' - | %ebx === `vuserf' <--- qt_t.sp - +--- - - When a varargs thread is started, it ``returns'' to the `qt_vstart' - startup code. The startup code calls the appropriate functions. */ - - -/* What to do to start a varargs thread running. */ -extern void qt_vstart (void); - - -/* Hold 4 saved regs plus two return pcs (qt_error, qt_start) plus - three args. */ -#define QT_STKBASE (9 * 4) - -/* Hold 4 saved regs plus one return pc (qt_vstart). */ -#define QT_VSTKBASE (5 * 4) - - -/* Stack must be 4-byte aligned. */ -#define QT_STKALIGN (4) - - -/* Where to place various arguments. */ -#define QT_ONLY_INDEX (QT_PC) -#define QT_USER_INDEX (QT_ARG2) -#define QT_ARGT_INDEX (QT_ARG1) -#define QT_ARGU_INDEX (QT_ARG0) - -#define QT_VSTARTUP_INDEX (QT_EBP) -#define QT_VUSERF_INDEX (QT_EBX) -#define QT_VCLEANUP_INDEX (QT_ESI) -#define QT_VARGT_INDEX (QT_EDI) - - -#define QT_EBX 0 -#define QT_EDI 1 -#define QT_ESI 2 -#define QT_EBP 3 -#define QT_PC 4 -/* The following are defined only for non-varargs. */ -#define QT_RPC 5 -#define QT_ARG0 6 -#define QT_ARG1 7 -#define QT_ARG2 8 - - -/* Stack grows down. The top of the stack is the first thing to - pop off (preincrement, postdecrement). */ -#define QT_GROW_DOWN - -extern void qt_error (void); - -/* Push on the error return address. */ -#define QT_ARGS_MD(sto) \ - (QT_SPUT (sto, QT_RPC, qt_error)) - - -/* When varargs are pushed, allocate space for all the args. */ -#define QT_VARGS_MD0(sto, nbytes) \ - ((qt_t *)(((char *)(sto)) - QT_STKROUNDUP(nbytes))) - -#define QT_VARGS_MD1(sto) \ - (QT_SPUT (sto, QT_PC, qt_vstart)) - -#define QT_VARGS_DEFAULT - -#endif /* QT_386_H */ diff --git a/qt/md/i386.s b/qt/md/i386.s deleted file mode 100644 index ed2c533d1..000000000 --- a/qt/md/i386.s +++ /dev/null @@ -1,108 +0,0 @@ -/* i386.s -- assembly support. */ - -/* -// QuickThreads -- Threads-building toolkit. -// Copyright (c) 1993 by David Keppel -// -// Permission to use, copy, modify and distribute this software and -// its documentation for any purpose and without fee is hereby -// granted, provided that the above copyright notice and this notice -// appear in all copies. This software is provided as a -// proof-of-concept and for demonstration purposes; there is no -// representation about the suitability of this software for any -// purpose. */ - -/* NOTE: double-labeled `_name' and `name' for System V compatability. */ -/* NOTE: Comment lines start with '/*' and '//' ONLY. Sorry! */ - -/* Callee-save: %esi, %edi, %ebx, %ebp -// Caller-save: %eax, %ecx -// Can't tell: %edx (seems to work w/o saving it.) -// -// Assignment: -// -// See ``i386.h'' for the somewhat unconventional stack layout. */ - - - .text - .align 2 - - .globl _qt_abort - .globl qt_abort - .globl _qt_block - .globl qt_block - .globl _qt_blocki - .globl qt_blocki - -/* These all have the type signature -// -// void *blocking (helper, arg0, arg1, new) -// -// On procedure entry, the helper is at 4(sp), args at 8(sp) and -// 12(sp) and the new thread's sp at 16(sp). It *appears* that the -// calling convention for the 8X86 requires the caller to save all -// floating-point registers, this makes our life easy. */ - -/* Halt the currently-running thread. Save it's callee-save regs on -// to the stack, 32 bytes. Switch to the new stack (next == 16+32(sp)) -// and call the user function (f == 4+32(sp) with arguments: old sp -// arg1 (8+32(sp)) and arg2 (12+32(sp)). When the user function is -// done, restore the new thread's state and return. -// -// `qt_abort' is (currently) an alias for `qt_block' because most of -// the work is shared. We could save the insns up to `qt_common' by -// replicating, but w/o replicating we need an inital subtract (to -// offset the stack as if it had been a qt_block) and then a jump -// to qt_common. For the cost of a jump, we might as well just do -// all the work. -// -// The helper function (4(sp)) can return a void* that is returned -// by the call to `qt_blockk{,i}'. Since we don't touch %eax in -// between, we get that ``for free''. */ - -_qt_abort: -qt_abort: -_qt_block: -qt_block: -_qt_blocki: -qt_blocki: - pushl %ebp /* Save callee-save, sp-=4. */ - pushl %esi /* Save callee-save, sp-=4. */ - pushl %edi /* Save callee-save, sp-=4. */ - pushl %ebx /* Save callee-save, sp-=4. */ - movl %esp, %eax /* Remember old stack pointer. */ - -qt_common: - movl 32(%esp), %esp /* Move to new thread. */ - pushl 28(%eax) /* Push arg 2. */ - pushl 24(%eax) /* Push arg 1. */ - pushl %eax /* Push arg 0. */ - movl 20(%eax), %ebx /* Get function to call. */ - call *%ebx /* Call f. */ - addl $12, %esp /* Pop args. */ - - popl %ebx /* Restore callee-save, sp+=4. */ - popl %edi /* Restore callee-save, sp+=4. */ - popl %esi /* Restore callee-save, sp+=4. */ - popl %ebp /* Restore callee-save, sp+=4. */ - ret /* Resume the stopped function. */ - hlt - - -/* Start a varargs thread. */ - - .globl _qt_vstart - .globl qt_vstart -_qt_vstart: -qt_vstart: - pushl %edi /* Push `pt' arg to `startup'. */ - call *%ebp /* Call `startup'. */ - popl %eax /* Clean up the stack. */ - - call *%ebx /* Call the user's function. */ - - pushl %eax /* Push return from user's. */ - pushl %edi /* Push `pt' arg to `cleanup'. */ - call *%esi /* Call `cleanup'. */ - - hlt /* `cleanup' never returns. */ diff --git a/qt/md/i386_b.s b/qt/md/i386_b.s deleted file mode 100644 index 32129a5d1..000000000 --- a/qt/md/i386_b.s +++ /dev/null @@ -1,30 +0,0 @@ -/* -// QuickThreads -- Threads-building toolkit. -// Copyright (c) 1993 by David Keppel -// -// Permission to use, copy, modify and distribute this software and -// its documentation for any purpose and without fee is hereby -// granted, provided that the above copyright notice and this notice -// appear in all copies. This software is provided as a -// proof-of-concept and for demonstration purposes; there is no -// representation about the suitability of this software for any -// purpose. */ - - .globl _b_call_reg - .globl b_call_reg - .globl _b_call_imm - .globl b_call_imm - .globl _b_add - .globl b_add - .globl _b_load - .globl b_load - -_b_call_reg: -b_call_reg: -_b_call_imm: -b_call_imm: -_b_add: -b_add: -_b_load: -b_load: - hlt diff --git a/qt/md/ksr1.Makefile b/qt/md/ksr1.Makefile deleted file mode 100644 index aa195839a..000000000 --- a/qt/md/ksr1.Makefile +++ /dev/null @@ -1,6 +0,0 @@ - -# -# KSR1 configuration. -# -CC = cc -ansi - diff --git a/qt/md/ksr1.h b/qt/md/ksr1.h deleted file mode 100644 index 83537a3c2..000000000 --- a/qt/md/ksr1.h +++ /dev/null @@ -1,164 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -#ifndef QT_KSR1_H -#define QT_KSR1_H - -/* - Stack layout: - - Registers are saved in strictly low to high order, FPU regs first - (only if qt_block is called), CEU regs second, IPU regs next, with no - padding between the groups. - - Callee-save: f16..f63; c15..c30; i12..i30. - Args passed in i2..i5. - - Note: c31 is a private data pointer. It is not changed on thread - swaps with the assumption that it represents per-processor rather - than per-thread state. - - Note: i31 is an instruction count register that is updated by the - context switch routines. Like c31, it is not changed on context - switches. - - This is what we want on startup: - - - +------ <-- BOS: Bottom of stack (grows down) - | 80 (128 - 48) bytes of padding to a 128-byte boundary - +--- - | only - | userf - | t - | u - | qt_start$TXT - | (empty) <-- qt.sp - +------ <-- (BOS - 128) - - This is why we want this on startup: - - A thread begins running when the restore procedure switches thread stacks - and pops a return address off of the top of the new stack (see below - for the reason why we explicitly store qt_start$TXT). The - block procedure pushes two jump addresses on a thread's stack before - it switches stacks. The first is the return address for the block - procedure, and the second is a restore address. The return address - is used to jump back to the thread that has been switched to; the - restore address is a jump within the block code to restore the registers. - Normally, this is just a jump to the next address. However, on thread - startup, this is a jump to qt_start$TXT. (The block procedure stores - the restore address at an offset of 8 bytes from the top of the stack, - which is also the offset at which qt_start$TXT is stored on the stacks - of new threads. Hence, when the block procedure switches to a new - thread stack, it will initially jump to qt_start$TXT; thereafter, - it jumps to the restore code.) - - qt_start$TXT, after it has read the initial data on the new thread's - stack and placed it in registers, pops the initial stack frame - and gives the thread the entire stack to use for execution. - - The KSR runtime system has an unusual treatment of pointers to - functions. From C, taking the `name' of a function yields a - pointer to a _constant block_ and *not* the address of the - function. The zero'th entry in the constant block is a pointer to - the function. - - We have to be careful: the restore procedure expects a return - address on the top of the stack (pointed to by qt.sp). This is not - a problem when restoring a thread that has run before, since the - block routine would have stored the return address on top of the - stack. However, when ``faking up'' a thread start (bootstrapping a - thread stack frame), the top of the stack needs to contain a - pointer to the code that will start the thread running. - - The pointer to the startup code is *not* `qt_start'. It is the - word *pointed to* by `qt_start'. Thus, we dereference `qt_start', - see QT_ARGS_MD below. - - On varargs startup (still unimplemented): - - | padding to 128 byte boundary - | varargs <-- padded to a 128-byte-boundary - +--- - | caller's frame, 16 bytes - | 80 bytes of padding (frame padded to a 128-byte boundary) - +--- - | cleanup - | vuserf - | startup - | t - +--- - | qt_start <-- qt.sp - +--- - - Of a suspended thread: - - +--- - | caller's frame, 16 bytes - | fpu registers 47 regs * 8 bytes/reg 376 bytes - | ceu registers 16 regs * 8 bytes/reg 128 bytes - | ipu registers 19 regs * 8 bytes/reg 152 bytes - | : - | 80 bytes of padding - | : - | qt_restore <-- qt.sp - +--- - - */ - - -#define QT_STKALIGN 128 -#define QT_GROW_DOWN -typedef unsigned long qt_word_t; - -#define QT_STKBASE QT_STKALIGN -#define QT_VSTKBASE QT_STKBASE - -extern void qt_start(void); -/* - * See the discussion above for what indexing into a procedure ptr - * does for us (it's lovely, though, isn't it?). - * - * This assumes that the address of a procedure's code is the - * first word in a procedure's constant block. That's how the manual - * says it will be arranged. - */ -#define QT_ARGS_MD(sp) (QT_SPUT (sp, 1, ((qt_word_t *)qt_start)[0])) - -/* - * The *index* (positive offset) of where to put each value. - * See the picture of the stack above that explains the offsets. - */ -#define QT_ONLY_INDEX (5) -#define QT_USER_INDEX (4) -#define QT_ARGT_INDEX (3) -#define QT_ARGU_INDEX (2) - -#define QT_VARGS_DEFAULT -#define QT_VARGS(sp, nb, vargs, pt, startup, vuserf, cleanup) \ - (qt_vargs (sp, nbytes, &vargs, pt, startup, vuserf, cleanup)) - - -#define QT_VARGS_MD0(sp, vabytes) \ - ((qt_t *)(((char *)(sp)) - 4*8 - QT_STKROUNDUP(vabytes))) - -extern void qt_vstart(void); -#define QT_VARGS_MD1(sp) (QT_SPUT (sp, 0, ((qt_word_t *)qt_vstart)[0])) - -#define QT_VCLEANUP_INDEX (4) -#define QT_VUSERF_INDEX (3) -#define QT_VSTARTUP_INDEX (2) -#define QT_VARGT_INDEX (1) - -#endif /* def QT_KSR1_H */ diff --git a/qt/md/ksr1.s b/qt/md/ksr1.s deleted file mode 100644 index d4d51a0a6..000000000 --- a/qt/md/ksr1.s +++ /dev/null @@ -1,424 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - - .file "ksr1.s" - .def .debug; .endef - - .align 128 - .globl qt_blocki - .globl qt_blocki$TXT - .globl qt_block - .globl qt_block$TXT - .globl qt_start$TXT - .globl qt_start - .globl qt_abort$TXT - .globl qt_abort - .globl qt_vstart - .globl qt_vstart$TXT - -# -# KSR convention: on procedure calls, load both the procedure address -# and a pointer to a constant block. The address of function `f' is -# `f$TXT', and the constant block address is `f'. The constant block -# has several reserved values: -# -# 8 bytes fpu register save mask -# 4 bytes ipu register save mask -# 4 bytes ceu register save mask -# f: f$TXT -# ... whatever you want ... (not quite...read on) -# -# Note, by the way, that a pointer to a function is passed as a -# pointer to the constant area, and the constant area has the text -# address. -# - -# -# Procedures that do not return structures prefix their code with -# -# proc$TXT: -# finop; cxnop -# finop; cxnop -# <proc code> -# -# Calls to those procedures branch to a 16 byte offset (4 instrs) in -# to the procedure to skip those instructions. -# -# Procedures that return structures use a different code prefix: -# -# proc$TXT: -# finop; beq.qt %rc, %rc, 24 # return value entry -# finop; cxnop -# finop; movi8 0, %rc # no return value entry -# <proc code> -# -# Calls that want the returned structure branch directly to the -# procedure address. Callers that don't want (or aren't expecting) a -# return value branche 16 bytes in to the procedure, which will zero -# %rc, telling the called procedure not to return a structure. -# - -# -# On entry: -# %i2 -- control block of helper function to run -# (dereference to get helper) -# %i3 -- a1 -# %i4 -- a2 -# %i5 -- sp of new to run -# - - .data - .half 0x0, 0x0, 0x7ffff000, 0x7fff8000 -qt_blocki: -qt_abort: - .word qt_blocki$TXT - .word qt_restore$TXT - - .text -qt_abort$TXT: -qt_blocki$TXT: - finop ; cxnop # entry prefix - finop ; cxnop # entry prefix - add8.ntr 75,%i31,%i31 ; movi8 512,%c5 # ICR; stk adjust - finop ; ssub8.ntr 0,%sp,%c5,%sp - finop ; st8 %fp,504(%sp) # Save caller's fp - finop ; st8 %cp,496(%sp) # Save caller's cp - finop ; ld8 8(%c10),%c5 # ld qt_restore$TXT - finop ; st8 %c14,0(%sp) # Save special ret addr - finop ; mov8_8 %c10, %cp # Our cp - finop ; sadd8.ntr 0,%sp,%c5,%fp # Our frame ptr - finop ; st8 %c5,8(%sp) # st qt_restore$TXT -# -# CEU registers %c15-%c24, %c26-%c30 (%c14 we restore later) -# - finop ; st8 %c15,456(%sp) - finop ; st8 %c16,448(%sp) - finop ; st8 %c17,440(%sp) - finop ; st8 %c18,432(%sp) - finop ; st8 %c19,424(%sp) - finop ; st8 %c20,416(%sp) - finop ; st8 %c21,408(%sp) - finop ; st8 %c22,400(%sp) - finop ; st8 %c23,392(%sp) - finop ; st8 %c24,384(%sp) -# -# %c25 is the Enclosing Frame Pointer (EFP) -- since C doesn't -# use nested procedures, we ignore it (leaving a gap, though) -# - finop ; st8 %c26,368(%sp) - finop ; st8 %c27,360(%sp) - finop ; st8 %c28,352(%sp) - finop ; st8 %c29,344(%sp) - finop ; st8 %c30,336(%sp) -# -# IPU registers %i12-%i30 -# - finop ; st8 %i12,328(%sp) - finop ; st8 %i13,320(%sp) - finop ; st8 %i14,312(%sp) - finop ; st8 %i15,304(%sp) -# (gap to get alignment for st64) -# -- Doesn't work on version 1.1.3 of the OS -# finop ; st64 %i16,256(%sp) - - finop ; st8 %i16,256(%sp) - finop ; st8 %i17,248(%sp) - finop ; st8 %i18,240(%sp) - finop ; st8 %i19,232(%sp) - finop ; st8 %i20,224(%sp) - finop ; st8 %i21,216(%sp) - finop ; st8 %i22,208(%sp) - finop ; st8 %i23,200(%sp) - finop ; st8 %i24,192(%sp) - finop ; st8 %i25,184(%sp) - finop ; st8 %i26,176(%sp) - finop ; st8 %i27,168(%sp) - finop ; st8 %i28,160(%sp) - finop ; st8 %i29,152(%sp) - finop ; st8 %i30,144(%sp) -# -# FPU already saved, or saving not necessary -# - -# -# Switch to the stack passed in as fourth argument to the block -# routine (%i5) and call the helper routine passed in as the first -# argument (%i2). Note that the address of the helper's constant -# block is passed in, so we must derefence it to get the helper's text -# address. -# - finop ; movb8_8 %i2,%c10 # helper's ConstBlock - finop ; cxnop # Delay slot, fill w/ - finop ; cxnop # .. 2 st8 from above - finop ; ld8 0(%c10),%c4 # load addr of helper - finop ; movb8_8 %sp, %i2 # 1st arg to helper - # is this stack; other - # args remain in regs - finop ; movb8_8 %i5,%sp # switch stacks - finop ; jsr %c14,16(%c4) # call helper - movi8 3, %i0 ; movi8 0,%c8 # nargs brain dmg - finop ; cxnop - finop ; cxnop -# -# Here is where behavior differs for threads being restored and threads -# being started. Blocked threads have a pointer to qt_restore$TXT on -# the top of their stacks; manufactured stacks have a pointer to qt_start$TXT -# on the top of their stacks. With this setup, starting threads -# skip the (unecessary) restore operations. -# -# We jump to an offset of 16 to either (1) skip past the two noop pairs -# at the start of qt_start$TXT, or (2) skip past the two noop pairs -# after qt_restore$TXT. -# - finop ; ld8 8(%sp),%c4 - finop ; cxnop - finop ; cxnop - finop ; jmp 16(%c4) -qt_restore$TXT: - finop ; cxnop - finop ; cxnop -# -# Point of Restore: -# -# The helper funtion will return here. Any result it has placed in -# a return register (most likely %i0) will not get overwritten below -# and will consequently be the return value of the blocking routine. -# - -# -# CEU registers %c15-%c24, %c26-%c30 (%c14 we restore later) -# - finop ; ld8 456(%sp),%c15 - finop ; ld8 448(%sp),%c16 - finop ; ld8 440(%sp),%c17 - finop ; ld8 432(%sp),%c18 - finop ; ld8 424(%sp),%c19 - finop ; ld8 416(%sp),%c20 - finop ; ld8 408(%sp),%c21 - finop ; ld8 400(%sp),%c22 - finop ; ld8 392(%sp),%c23 - finop ; ld8 384(%sp),%c24 -# -# %c25 is the Enclosing Frame Pointer (EFP) -- since C doesn't -# use nested procedures, we ignore it (leaving a gap, though) -# - finop ; ld8 368(%sp),%c26 - finop ; ld8 360(%sp),%c27 - finop ; ld8 352(%sp),%c28 - finop ; ld8 344(%sp),%c29 - finop ; ld8 336(%sp),%c30 -# -# IPU registers %i12-%i30 -# - finop ; ld8 328(%sp),%i12 - finop ; ld8 320(%sp),%i13 - finop ; ld8 312(%sp),%i14 - finop ; ld8 304(%sp),%i15 -# (gap to get alignment for ld64) -# -- Doesn't work on version 1.1.3 of the OS -# finop ; ld64 256(%sp),%i16 - - finop ; ld8 256(%sp),%i16 - finop ; ld8 248(%sp),%i17 - finop ; ld8 240(%sp),%i18 - finop ; ld8 232(%sp),%i19 - finop ; ld8 224(%sp),%i20 - finop ; ld8 216(%sp),%i21 - finop ; ld8 208(%sp),%i22 - finop ; ld8 200(%sp),%i23 - finop ; ld8 192(%sp),%i24 - finop ; ld8 184(%sp),%i25 - finop ; ld8 176(%sp),%i26 - finop ; ld8 168(%sp),%i27 - finop ; ld8 160(%sp),%i28 - finop ; ld8 152(%sp),%i29 - finop ; ld8 144(%sp),%i30 - -# -# FPU registers don't need to be loaded, or will be loaded by an -# enclosing scope (e.g., if this is called by qt_block). -# - -# -# Load the special registers. We don't load the stack ptr because -# the new stack is passed in as an argument, we don't load the EFP -# because we don't use it, and we load the return address specially -# off the top of the stack. -# - finop ; ld8 0(%sp),%c14 # return addr - finop ; ld8 496(%sp),%cp - finop ; ld8 504(%sp),%fp - - finop ; jmp 32(%c14) # jump back to thread - finop ; movi8 512,%c5 # stack adjust - finop ; sadd8.ntr 0,%sp,%c5,%sp - - .data - .half 0x0, 0x0, 0x7ffff000, 0x7fff8000 -qt_block: - .word qt_block$TXT - .word qt_error - .word qt_error$TXT - .word qt_blocki -# -# Handle saving and restoring the FPU regs, relying on qt_blocki -# to save and restore the remaining registers. -# - .text -qt_block$TXT: - finop ; cxnop # entry prefix - finop ; cxnop # entry prefix - - add8.ntr 29,%i31,%i31 ; movi8 512,%c5 # ICR; stk adjust - finop ; ssub8.ntr 0,%sp,%c5,%sp - finop ; st8 %fp,504(%sp) # Save caller's fp - finop ; st8 %cp,496(%sp) # Save caller's cp - finop ; st8 %c14,488(%sp) # store ret addr - finop ; sadd8.ntr 0,%sp,%c5,%fp # Our frame ptr - finop ; mov8_8 %c10, %cp # Our cp - -# -# Store 8 registers at once...destination must be a multiple of 64 -# - finop ; st64 %f16,384(%sp) - finop ; st64 %f24,320(%sp) - finop ; st64 %f32,256(%sp) - finop ; st64 %f40,192(%sp) - finop ; st64 %f48,128(%sp) - finop ; st64 %f56,64(%sp) - -# -# Call the integer blocking routine, passing the arguments passed to us -# - finop ; ld8 24(%cp), %c10 - finop ; cxnop - finop ; jsr %c14, qt_blocki$TXT - finop ; cxnop - finop ; cxnop - movi8 4,%i0 ; movi8 0,%c8 # nargs brain dmg - -# -# Load 8 registers at once...source must be a multiple of 64 -# - finop ; ld64 64(%sp),%f56 - finop ; ld64 128(%sp),%f48 - finop ; ld64 192(%sp),%f40 - finop ; ld64 256(%sp),%f32 - finop ; ld64 320(%sp),%f24 - finop ; ld64 384(%sp),%f16 - - finop ; ld8 488(%sp),%c14 - finop ; ld8 496(%sp),%cp - finop ; ld8 504(%sp),%fp - finop ; jmp 32(%c14) # jump back to thread - finop ; movi8 512,%c5 # stack adjust - finop ; sadd8.ntr 0,%sp,%c5,%sp - - - .data - .half 0x0, 0x0, 0x7ffff000, 0x7fff8000 -qt_start: - .word qt_start$TXT -# -# A new thread is set up to "appear" as if it were executing code at -# the beginning of qt_start and then it called a blocking routine -# (qt_blocki). So when a new thread starts to run, it gets unblocked -# by the code above and "returns" to `qt_start$TXT' in the -# restore step of the switch. Blocked threads jump to 16(qt_restore$TXT), -# and starting threads jump to 16(qt_start$TXT). -# - .text -qt_start$TXT: - finop ; cxnop # - finop ; cxnop # - finop ; ld8 40(%sp),%c10 # `only' constant block - finop ; ld8 32(%sp),%i4 # `userf' arg. - finop ; ld8 24(%sp),%i3 # `t' arg. - finop ; ld8 0(%c10),%c4 # `only' text location - finop ; ld8 16(%sp),%i2 # `u' arg. - finop ; cxnop - finop ; jsr %c14,16(%c4) # call `only' -# -# Pop the frame used to store the thread's initial data -# - finop ; sadd8.ntr 0,%sp,128,%sp - finop ; cxnop - movi8 2,%i0 ; movi8 0,%c8 # nargs brain dmg -# -# If we ever return, it's an error. -# - finop ; jmp qt_error$TXT - finop ; cxnop - finop ; cxnop - movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg - - -# -# This stuff is broken -# - .data - .half 0x0, 0x0, 0x7ffff000, 0x7fff8000 -qt_vstart: - .word qt_vstart$TXT - - .text -qt_vstart$TXT: - finop ; cxnop # entry prefix - finop ; cxnop # entry prefix - finop ; cxnop - finop ; cxnop - add8.ntr 11,%i31,%i31 ; movi8 512,%c5 - finop ; ssub8.ntr 0,%sp,%c5,%sp # fix stack - finop ; ld8 8(%sp),%i2 # load `t' as arg to - finop ; cxnop # `startup' - finop ; cxnop - finop ; ld8 16(%sp),%c10 # `startup' const block - finop ; cxnop - finop ; cxnop - finop ; ld8 0(%c10),%c4 # `startup' text loc. - finop ; cxnop - finop ; cxnop - finop ; jsr %c14,16(%c4) # call `startup' - finop ; cxnop - finop ; cxnop - movi8 1, %i0 ; movi8 0,%c8 # nargs brain dmg -# -# finop ; sadd 0,%sp,128,%sp # alter stack -# - finop ; ld8 8(%sp),%i2 # load `t' as arg to - finop ; ld8 8(%sp),%i2 # load `t' as arg to - finop ; ld8 8(%sp),%i2 # load `t' as arg to - finop ; ld8 8(%sp),%i2 # load `t' as arg to - - finop ; ld8 32(%sp),%c10 # `only' constant block - finop ; ld8 8(%sp),%i2 # `u' arg. - finop ; ld8 16(%sp),%i3 # `t' arg. - finop ; ld8 0(%c10),%c4 # `only' text location - finop ; ld8 24(%sp),%i4 # `userf' arg. - finop ; cxnop - finop ; jsr %c4,16(%c4) # call `only' - finop ; cxnop - finop ; cxnop -# -# If the callee ever calls `nargs', the following instruction (pair) -# will be executed. However, we don't know when we compile this code -# how many args are being passed. So we give our best guess: 0. -# - movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg -# -# If we ever return, it's an error. -# - finop ; jmp qt_error$TXT - finop ; cxnop - finop ; cxnop - movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg diff --git a/qt/md/ksr1_b.s b/qt/md/ksr1_b.s deleted file mode 100644 index 80b0c59eb..000000000 --- a/qt/md/ksr1_b.s +++ /dev/null @@ -1,49 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - - .file "ksr1_b.s" - .def .debug; .endef - - .globl b_call_reg$TXT - .globl b_call_reg - .globl b_call_imm$TXT - .globl b_call_imm - .globl b_add$TXT - .globl b_add - .globl b_load$TXT - .globl b_load - - -b_call_reg: -b_call_imm: -b_add: -b_load: - .word b_call_reg$TXT - .word qt_error - .word qt_error$TXT - - -b_call_reg$TXT: -b_call_imm$TXT: -b_add$TXT: -b_load$TXT: - finop ; cxnop - finop ; cxnop - finop ; ld8 16(%cp),%c4 - finop ; ld8 8(%cp),%cp - finop ; cxnop - finop ; cxnop - finop ; jsr %c4,0(%c4) - finop ; cxnop - finop ; cxnop - diff --git a/qt/md/m88k.Makefile b/qt/md/m88k.Makefile deleted file mode 100644 index 608c70690..000000000 --- a/qt/md/m88k.Makefile +++ /dev/null @@ -1,6 +0,0 @@ - -# -# Hosted compilers for 88k for Meerkat. -# -CC = gcc88 -Dm88k -ansi -pedantic -Wall -fno-builtin -AS = as88 diff --git a/qt/md/m88k.c b/qt/md/m88k.c deleted file mode 100644 index 9e3ae8ba8..000000000 --- a/qt/md/m88k.c +++ /dev/null @@ -1,111 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -#include <stdarg.h> -#include "qt.h" - -/* Varargs is harder on the m88k. Parameters are saved on the stack as - something like (stack grows down to low memory; low at bottom of - picture): - - | : - | arg8 <-- va_list.__va_stk - +--- - | : - +--- - | arg7 - | : - | iarg0 <-- va_list.__va_reg - +--- - | : - | va_list { __va_arg, __va_stk, __va_reg } - | : - +--- - - Here, `va_list.__va_arg' is the number of word-size arguments - that have already been skipped. Doubles must be double-arligned. - - What this means for us is that the user's routine needs to be - called with an arg list where some of the words in the `__va_stk' - part of the parameter list have to be promoted to registers. - - BUG: doubleword register arguments must be double-aligned. If - something is passed as an even # arg and used as an odd # arg or - vice-versa, the code in the called routine (in the new thread) that - decides how to adjust the index will get it wrong, because it will - be expect it to be, say, doubleword aligned and it will really be - singleword aligned. - - I'm not sure you can solve this without knowing the types of all - the arguments. All in all, we never promised varargs would work - reliably. */ - - - -#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE) - -/* Always allocate at least enough space for 8 args; waste some space - at the base of the stack to ensure the startup routine doesn't read - off the end of the stack. */ - -#define QT_VARGS_MD0(sp, vabytes) \ - ((qt_t *)(((char *)(sp)) - 8*4 - QT_STKROUNDUP(vabytes))) - -extern void qt_vstart(void); -#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_1, qt_vstart)) - - - struct qt_t * -qt_vargs (struct qt_t *qsp, int nbytes, void *vargs, - void *pt, qt_function_t *startup, - qt_function_t *vuserf, qt_function_t *cleanup) -{ - va_list ap; - int i; - int n; /* Number of words into original arg list. */ - qt_word_t *sp; - int *reg; /* Where to read passed-in-reg args. */ - int *stk; /* Where to read passed-on-stk args. */ - - ap = *(va_list *)vargs; - qsp = QT_VARGS_MD0 (qsp, nbytes); - sp = (qt_word_t *)qsp; - - reg = (ap.__va_arg < 8) - ? &ap.__va_reg[ap.__va_arg] - : 0; - stk = &ap.__va_stk[8]; - n = ap.__va_arg; - for (i=0; i<nbytes/sizeof(qt_word_t) && n<8; ++i,++n) { - sp[i] = *reg++; - } - for (; i<nbytes/sizeof(qt_word_t); ++i) { - sp[i] = *stk++; - } - -#ifdef QT_NDEF - for (i=0; i<nbytes/sizeof(qt_word_t); ++i) { - sp[i] = (n < 8) - ? *reg++ - : *stk++; - ++n; - } -#endif - - QT_VARGS_MD1 (QT_VADJ(sp)); - QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt); - QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup); - QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf); - QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup); - return ((qt_t *)QT_VADJ(sp)); -} diff --git a/qt/md/m88k.h b/qt/md/m88k.h deleted file mode 100644 index df7e07a85..000000000 --- a/qt/md/m88k.h +++ /dev/null @@ -1,159 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -#ifndef QT_M88K_H -#define QT_M88K_H - -typedef unsigned long qt_word_t; - -#define QT_GROW_DOWN - -/* Stack layout on the mips: - - Callee-save registers are: $16-$23, $30; $f20-$f30. - Also save $31, return pc. - - Non-varargs: - - +--- - | r30 (fp) on startup === 0 - | r25 - | r24 - | r23 - | r22 - | r21 - | r20 - | r19 - | r18 - | r17 on startup === `only' - | r16 on startup === `userf' - | r15 on startup === `pt' - | r14 on startup === `pu' - | r1 on startup === `qt_start' - | 0 - | 0 - +--- - | 0 - | ... (8 regs worth === 32 bytes of homing area) - | 0 <--- sp - +--- - - Conventions for varargs: - - | : - | arg8 - +--- - | r30 (fp) arg7 - | r25 arg6 - | r24 arg5 - | r23 arg4 - | r22 arg3 - | r21 arg2 - | r20 arg1 - | r19 arg0 - | r18 - | r17 on startup === `startup' - | r16 on startup === `vuserf' - | r15 on startup === `pt' - | r14 on startup === `cleanup' - | r1 on startup === `qt_vstart' - | 0 - | 0 - +--- - | 0 - | ... (8 regs worth === 32 bytes of homing area) - | 0 <--- sp - +--- - - */ - - -/* Stack must be doubleword aligned. */ -#define QT_STKALIGN (16) /* Doubleword aligned. */ - -/* How much space is allocated to hold all the crud for - initialization: saved registers plus padding to keep the stack - aligned plus 8 words of padding to use as a `homing area' (for - r2-r9) when calling helper functions on the stack of the (not yet - started) thread. The varargs save area is small because it gets - overlapped with the top of the parameter list. In case the - parameter list is less than 8 args, QT_ARGS_MD0 adds some dead - space at the top of the stack. */ - -#define QT_STKBASE (16*4 + 8*4) -#define QT_VSTKBASE (8*4 + 8*4) - - -/* Index of various registers. */ -#define QT_1 (8+2) -#define QT_14 (8+3) -#define QT_15 (8+4) -#define QT_16 (8+5) -#define QT_17 (8+6) -#define QT_30 (8+15) - - -/* When a never-before-run thread is restored, the return pc points - to a fragment of code that starts the thread running. For - non-vargs functions, it sets up arguments and calls the client's - `only' function. For varargs functions, the startup code calls the - startup, user, and cleanup functions. - - For non-varargs functions, we set the frame pointer to 0 to - null-terminate the call chain. - - For varargs functions, the frame pointer register is used to hold - one of the arguments, so that all arguments can be laid out in - memory by the conventional `qt_vargs' varargs initialization - routine. - - The varargs startup routine always reads 8 words of arguments from - the stack. If there are less than 8 words of arguments, then the - arg list could call off the top of the stack. To prevent fall-off, - always allocate 8 words. */ - -extern void qt_start(void); -#define QT_ARGS_MD(sp) \ - (QT_SPUT (sp, QT_1, qt_start), \ - QT_SPUT (sp, QT_30, 0)) - - -/* The m88k uses a struct for `va_list', so pass a pointer to the - struct. */ - -typedef void (qt_function_t)(void); - -struct qt_t; -extern struct qt_t *qt_vargs (struct qt_t *sp, int nbytes, - void *vargs, void *pt, - qt_function_t *startup, - qt_function_t *vuserf, - qt_function_t *cleanup); - -#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \ - (qt_vargs (sp, nbytes, &(vargs), pt, (qt_function_t *)startup, \ - (qt_function_t *)vuserf, (qt_function_t *)cleanup)) - - -/* The *index* (positive offset) of where to put each value. */ -#define QT_ONLY_INDEX (QT_17) -#define QT_USER_INDEX (QT_16) -#define QT_ARGT_INDEX (QT_15) -#define QT_ARGU_INDEX (QT_14) - -#define QT_VCLEANUP_INDEX (QT_14) -#define QT_VUSERF_INDEX (QT_16) -#define QT_VSTARTUP_INDEX (QT_17) -#define QT_VARGT_INDEX (QT_15) - -#endif /* ndef QT_M88K_H */ diff --git a/qt/md/m88k.s b/qt/md/m88k.s deleted file mode 100644 index 42467e8d5..000000000 --- a/qt/md/m88k.s +++ /dev/null @@ -1,132 +0,0 @@ -/* m88k.s -- assembly support. */ - -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -/* Callee-save r14..r25, r31(sp), r30(fp). r1 === return pc. - * Argument registers r2..r9, return value r2..r3. - * - * On startup, restore regs so retpc === call to a function to start. - * - * We're going to call a function (r2) from within the context switch - * routine. Call it on the new thread's stack on behalf of the old - * thread. - */ - - .globl _qt_block - .globl _qt_blocki - .globl _qt_abort - .globl _qt_start - .globl _qt_vstart - - /* - ** r2: ptr to function to call once curr is suspended - ** and control is on r5's stack. - ** r3: 1'th arg to *r2. - ** r4: 2'th arg to *r2. - ** r5: sp of thread to suspend. - ** - ** The helper routine returns a value that is passed on as the - ** return value from the blocking routine. Since we don't - ** touch r2 between the helper's return and the end of - ** function, we get this behavior for free. - ** - ** Same entry for integer-only and floating-point, since there - ** are no separate integer and floating-point registers. - ** - ** Each procedure call sets aside a ``home region'' of 8 regs - ** for r2-r9 for varargs. For context switches we don't use - ** the ``home region'' for varargs so use it to save regs. - ** Allocate 64 bytes of save space -- use 32 bytes of register - ** save area passed in to us plus 32 bytes we allcated, use - ** the other 32 bytes for save area for a save area to call - ** the helper function. - */ -_qt_block: -_qt_blocki: - sub r31, r31,64 /* Allocate reg save space. */ - st r1, r31,8+32 /* Save callee-save registers. */ - st r14, r31,12+32 - st.d r15, r31,16+32 - st.d r17, r31,24+32 - st.d r19, r31,32+32 - st.d r21, r31,40+32 - st.d r23, r31,48+32 - st r25, r31,56+32 - st r30, r31,60+32 - -_qt_abort: - addu r14, r31,0 /* Remember old sp. */ - addu r31, r5,0 /* Set new sp. */ - jsr.n r2 /* Call helper. */ - addu r2, r14,0 /* Pass old sp as an arg0 to helper. */ - - ld r1, r31,8+32 /* Restore callee-save registers. */ - ld r14, r31,12+32 - ld.d r15, r31,16+32 - ld.d r17, r31,24+32 - ld.d r19, r31,32+32 - ld.d r21, r31,40+32 - ld.d r23, r31,48+32 - ld r25, r31,56+32 - ld r30, r31,60+32 - - jmp.n r1 /* Return to new thread's caller. */ - addu r31, r31,64 /* Free register save space. */ - - - /* - ** Non-varargs thread startup. - ** See `m88k.h' for register use conventions. - */ -_qt_start: - addu r2, r14,0 /* Set user arg `pu'. */ - addu r3, r15,0 /* ... user function pt. */ - jsr.n r17 /* Call `only'. */ - addu r4, r16,0 /* ... user function userf. */ - - bsr _qt_error /* `only' erroniously returned. */ - - - /* - ** Varargs thread startup. - ** See `m88k.h' for register use conventions. - ** - ** Call the `startup' function with just argument `pt'. - ** Then call `vuserf' with 8 register args plus any - ** stack args. - ** Then call `cleanup' with `pt' and the return value - ** from `vuserf'. - */ -_qt_vstart: - addu r18, r30,0 /* Remember arg7 to `vuserf'. */ - addu r30, r0,0 /* Null-terminate call chain. */ - - jsr.n r17 /* Call `startup'. */ - addu r2, r15,0 /* `pt' is arg0 to `startup'. */ - - addu r2, r19,0 /* Set arg0. */ - addu r3, r20,0 /* Set arg1. */ - addu r4, r21,0 /* Set arg2. */ - addu r5, r22,0 /* Set arg3. */ - addu r6, r23,0 /* Set arg4. */ - addu r7, r24,0 /* Set arg5. */ - addu r8, r25,0 /* Set arg6. */ - jsr.n r16 /* Call `vuserf'. */ - addu r9, r18,0 /* Set arg7. */ - - addu r3, r2,0 /* Ret. value is arg1 to `cleanup'. */ - jsr.n r14 /* Call `cleanup'. */ - addu r2, r15,0 /* `pt' is arg0 to `cleanup'. */ - - bsr _qt_error /* `cleanup' erroniously returned. */ diff --git a/qt/md/m88k_b.s b/qt/md/m88k_b.s deleted file mode 100644 index 1926e6ae8..000000000 --- a/qt/md/m88k_b.s +++ /dev/null @@ -1,117 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - - .text - .globl _b_call_reg - .globl _b_call_imm - .globl _b_add - .globl _b_load - -_b_null: - jmp r1 - -_b_call_reg: - subu r31, r31,8 /* Alloc ret pc save space. */ - st r1, r31,32 /* Save ret pc. */ - or.u r3, r0,hi16(_b_null) /* Put call addr in a reg. */ - or r3, r3,lo16(_b_null) - jsr r3 -L0: - jsr r3 - jsr r3 - jsr r3 - jsr.n r3 - subu r2, r2,5 /* Decrement #of iter to go. */ - bcnd.n gt0,r2,L0 - jsr r3 - - ld r1, r31,32 - jmp r1 - - -_b_call_imm: - subu r31, r31,8 /* Alloc ret pc save space. */ - st r1, r31,32 /* Save ret pc. */ - bsr _b_null -L1: - bsr _b_null - bsr _b_null - bsr _b_null - bsr.n _b_null - subu r2, r2,5 /* Decrement #of iter to go. */ - bcnd.n gt0,r2,L1 - bsr _b_null - - ld r1, r31,32 - jmp r1 - -_b_add: - add r0, r3,r4 -L2: - add r3, r4,r5 - add r4, r5,r6 - add r5, r6,r7 - add r8, r9,r0 - add r0, r3,r4 - add r3, r4,r5 - add r4, r5,r6 - add r5, r6,r7 - add r8, r9,r0 - - add r0, r3,r4 - add r3, r4,r5 - add r4, r5,r6 - add r5, r6,r7 - add r8, r9,r0 - add r0, r3,r4 - add r3, r4,r5 - add r4, r5,r6 - add r5, r6,r7 - add r8, r9,r0 - - subu r2, r2,20 /* Decrement #of iter to go. */ - bcnd.n gt0,r2,L2 - add r0, r3,r4 - - jmp r1 - - -_b_load: - ld r0, r31,0 -L3: - ld r3, r31,4 - ld r4, r31,8 - ld r5, r31,12 - ld r6, r31,16 - ld r0, r31,0 - ld r3, r31,4 - ld r4, r31,8 - ld r5, r31,12 - ld r6, r31,16 - - ld r0, r31,0 - ld r3, r31,4 - ld r4, r31,8 - ld r5, r31,12 - ld r6, r31,16 - ld r0, r31,0 - ld r3, r31,4 - ld r4, r31,8 - ld r5, r31,12 - ld r6, r31,16 - - subu r2, r2,20 /* Decrement #of iter to go. */ - bcnd.n gt0,r2,L3 - ld r0, r31,0 - - jmp r1 diff --git a/qt/md/mips-irix5.s b/qt/md/mips-irix5.s deleted file mode 100644 index 234a953ed..000000000 --- a/qt/md/mips-irix5.s +++ /dev/null @@ -1,182 +0,0 @@ -/* mips.s -- assembly support. */ - -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -/* Callee-save $16-$23, $30-$31. - * - * $25 is used as a procedure value pointer, used to discover constants - * in a callee. Thus, each caller here sets $25 before the call. - * - * On startup, restore regs so retpc === call to a function to start. - * We're going to call a function ($4) from within this routine. - * We're passing 3 args, therefore need to allocate 12 extra bytes on - * the stack for a save area. The start routine needs a like 16-byte - * save area. Must be doubleword aligned (_mips r3000 risc - * architecture_, gerry kane, pg d-23). - */ - -/* - * Modified by Assar Westerlund <assar@sics.se> to support Irix 5.x - * calling conventions for dynamically-linked code. - */ - - /* Make this position-independent code. */ - .option pic2 - - .globl qt_block - .globl qt_blocki - .globl qt_abort - .globl qt_start - .globl qt_vstart - - /* - ** $4: ptr to function to call once curr is suspended - ** and control is on $7's stack. - ** $5: 1'th arg to $4. - ** $6: 2'th arg to $4 - ** $7: sp of thread to suspend. - ** - ** Totally gross hack: The MIPS calling convention reserves - ** 4 words on the stack for a0..a3. This routine "ought" to - ** allocate space for callee-save registers plus 4 words for - ** the helper function, but instead we use the 4 words - ** provided by the function that called us (we don't need to - ** save our argument registers). So what *appears* to be - ** allocating only 40 bytes is actually allocating 56, by - ** using the caller's 16 bytes. - ** - ** The helper routine returns a value that is passed on as the - ** return value from the blocking routine. Since we don't - ** touch $2 between the helper's return and the end of - ** function, we get this behavior for free. - */ -qt_blocki: - sub $sp,$sp,40 /* Allocate reg save space. */ - sw $16, 0+16($sp) - sw $17, 4+16($sp) - sw $18, 8+16($sp) - sw $19,12+16($sp) - sw $20,16+16($sp) - sw $21,20+16($sp) - sw $22,24+16($sp) - sw $23,28+16($sp) - sw $30,32+16($sp) - sw $31,36+16($sp) - add $2, $sp,$0 /* $2 <= old sp to pass to func@$4. */ -qt_abort: - add $sp, $7,$0 /* $sp <= new sp. */ - .set noreorder - add $25, $4,$0 /* Set helper function procedure value. */ - jal $31,$25 /* Call helper func@$4 . */ - add $4, $2,$0 /* $a0 <= pass old sp as a parameter. */ - .set reorder - lw $31,36+16($sp) /* Restore callee-save regs... */ - lw $30,32+16($sp) - lw $23,28+16($sp) - lw $22,24+16($sp) - lw $21,20+16($sp) - lw $20,16+16($sp) - lw $19,12+16($sp) - lw $18, 8+16($sp) - lw $17, 4+16($sp) - lw $16, 0+16($sp) /* Restore callee-save */ - - add $sp,$sp,40 /* Deallocate reg save space. */ - j $31 /* Return to caller. */ - - /* - ** Non-varargs thread startup. - ** Note: originally, 56 bytes were allocated on the stack. - ** The thread restore routine (_blocki/_abort) removed 40 - ** of them, which means there is still 16 bytes for the - ** argument area required by the MIPS calling convention. - */ -qt_start: - add $4, $16,$0 /* Load up user function pu. */ - add $5, $17,$0 /* ... user function pt. */ - add $6, $18,$0 /* ... user function userf. */ - add $25, $19,$0 /* Set `only' procedure value. */ - jal $31,$25 /* Call `only'. */ - la $25,qt_error /* Set `qt_error' procedure value. */ - j $25 - - - /* - ** Save calle-save floating-point regs $f20-$f30 - ** See comment in `qt_block' about calling conventinos and - ** reserved space. Use the same trick here, but here we - ** actually have to allocate all the bytes since we have to - ** leave 4 words leftover for `qt_blocki'. - ** - ** Return value from `qt_block' is the same as the return from - ** `qt_blocki'. We get that for free since we don't touch $2 - ** between the return from `qt_blocki' and the return from - ** `qt_block'. - */ -qt_block: - sub $sp, $sp,56 /* 6 8-byte regs, saved ret pc, aligned. */ - swc1 $f20, 0+16($sp) - swc1 $f22, 8+16($sp) - swc1 $f24, 16+16($sp) - swc1 $f26, 24+16($sp) - swc1 $f28, 32+16($sp) - swc1 $f30, 40+16($sp) - sw $31, 48+16($sp) - jal qt_blocki - lwc1 $f20, 0+16($sp) - lwc1 $f22, 8+16($sp) - lwc1 $f24, 16+16($sp) - lwc1 $f26, 24+16($sp) - lwc1 $f28, 32+16($sp) - lwc1 $f30, 40+16($sp) - lw $31, 48+16($sp) - add $sp, $sp,56 - j $31 - - - /* - ** First, call `startup' with the `pt' argument. - ** - ** Next, call the user's function with all arguments. - ** Note that we don't know whether args were passed in - ** integer regs, fp regs, or on the stack (See Gerry Kane - ** "MIPS R2000 RISC Architecture" pg D-22), so we reload - ** all the registers, possibly with garbage arguments. - ** - ** Finally, call `cleanup' with the `pt' argument and with - ** the return value from the user's function. It is an error - ** for `cleanup' to return. - */ -qt_vstart: - add $4, $17,$0 /* `pt' is arg0 to `startup'. */ - add $25, $18,$0 /* Set `startup' procedure value. */ - jal $31, $25 /* Call `startup'. */ - - add $sp, $sp,16 /* Free extra save space. */ - lw $4, 0($sp) /* Load up args. */ - lw $5, 4($sp) - lw $6, 8($sp) - lw $7, 12($sp) - lwc1 $f12, 0($sp) /* Load up fp args. */ - lwc1 $f14, 8($sp) - add $25, $19,$0 /* Set `userf' procedure value. */ - jal $31,$25 /* Call `userf'. */ - - add $4, $17,$0 /* `pt' is arg0 to `cleanup'. */ - add $5, $2,$0 /* Ret. val is arg1 to `cleanup'. */ - add $25, $16,$0 /* Set `cleanup' procedure value. */ - jal $31, $25 /* Call `cleanup'. */ - - la $25,qt_error /* Set `qt_error' procedure value. */ - j $25 diff --git a/qt/md/mips.h b/qt/md/mips.h deleted file mode 100644 index c584a681e..000000000 --- a/qt/md/mips.h +++ /dev/null @@ -1,134 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -#ifndef QT_MIPS_H -#define QT_MIPS_H - -typedef unsigned long qt_word_t; - -#define QT_GROW_DOWN - -/* Stack layout on the mips: - - Callee-save registers are: $16-$23, $30; $f20-$f30. - Also save $31, return pc. - - Non-varargs: - - +--- - | $f30 The first clump is only saved if `qt_block' - | $f28 is called, in which case it saves the fp regs - | $f26 then calls `qt_blocki' to save the int regs. - | $f24 - | $f22 - | $f20 - | $31 === return pc in `qt_block' - +--- - | $31 === return pc; on startup == qt_start - | $30 - | $23 - | $22 - | $21 - | $20 - | $19 on startup === only - | $18 on startup === $a2 === userf - | $17 on startup === $a1 === pt - | $16 on startup === $a0 === pu - | <a3> save area req'd by MIPS calling convention - | <a2> save area req'd by MIPS calling convention - | <a1> save area req'd by MIPS calling convention - | <a0> save area req'd by MIPS calling convention <--- sp - +--- - - Conventions for varargs: - - | args ... - +--- - | : - | : - | $21 - | $20 - | $19 on startup === `userf' - | $18 on startup === `startup' - | $17 on startup === `pt' - | $16 on startup === `cleanup' - | <a3> - | <a2> - | <a1> - | <a0> <--- sp - +--- - - Note: if we wanted to, we could muck about and try to get the 4 - argument registers loaded in to, e.g., $22, $23, $30, and $31, - and the return pc in, say, $20. Then, the first 4 args would - not need to be loaded from memory, they could just use - register-to-register copies. */ - - -/* Stack must be doubleword aligned. */ -#define QT_STKALIGN (8) /* Doubleword aligned. */ - -/* How much space is allocated to hold all the crud for - initialization: $16-$23, $30, $31. Just do an integer restore, - no need to restore floating-point. Four words are needed for the - argument save area for the helper function that will be called for - the old thread, just before the new thread starts to run. */ - -#define QT_STKBASE (14 * 4) -#define QT_VSTKBASE QT_STKBASE - - -/* Offsets of various registers. */ -#define QT_31 (9+4) -#define QT_19 (3+4) -#define QT_18 (2+4) -#define QT_17 (1+4) -#define QT_16 (0+4) - - -/* When a never-before-run thread is restored, the return pc points - to a fragment of code that starts the thread running. For - non-vargs functions, it just calls the client's `only' function. - For varargs functions, it calls the startup, user, and cleanup - functions. - - The varargs startup routine always reads 4 words of arguments from - the stack. If there are less than 4 words of arguments, then the - startup routine can read off the top of the stack. To prevent - errors we always allocate 4 words. If there are more than 3 words - of arguments, the 4 preallocated words are simply wasted. */ - -extern void qt_start(void); -#define QT_ARGS_MD(sp) (QT_SPUT (sp, QT_31, qt_start)) - -#define QT_VARGS_MD0(sp, vabytes) \ - ((qt_t *)(((char *)(sp)) - 4*4 - QT_STKROUNDUP(vabytes))) - -extern void qt_vstart(void); -#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_31, qt_vstart)) - -#define QT_VARGS_DEFAULT - - -/* The *index* (positive offset) of where to put each value. */ -#define QT_ONLY_INDEX (QT_19) -#define QT_USER_INDEX (QT_18) -#define QT_ARGT_INDEX (QT_17) -#define QT_ARGU_INDEX (QT_16) - -#define QT_VCLEANUP_INDEX (QT_16) -#define QT_VUSERF_INDEX (QT_19) -#define QT_VSTARTUP_INDEX (QT_18) -#define QT_VARGT_INDEX (QT_17) - -#endif /* ndef QT_MIPS_H */ diff --git a/qt/md/mips.s b/qt/md/mips.s deleted file mode 100644 index b074b98dc..000000000 --- a/qt/md/mips.s +++ /dev/null @@ -1,164 +0,0 @@ -/* mips.s -- assembly support. */ - -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -/* Callee-save $16-$23, $30-$31. - * - * On startup, restore regs so retpc === call to a function to start. - * We're going to call a function ($4) from within this routine. - * We're passing 3 args, therefore need to allocate 12 extra bytes on - * the stack for a save area. The start routine needs a like 16-byte - * save area. Must be doubleword aligned (_mips r3000 risc - * architecture_, gerry kane, pg d-23). - */ - - .globl qt_block - .globl qt_blocki - .globl qt_abort - .globl qt_start - .globl qt_vstart - - /* - ** $4: ptr to function to call once curr is suspended - ** and control is on $7's stack. - ** $5: 1'th arg to $4. - ** $6: 2'th arg to $4 - ** $7: sp of thread to suspend. - ** - ** Totally gross hack: The MIPS calling convention reserves - ** 4 words on the stack for a0..a3. This routine "ought" to - ** allocate space for callee-save registers plus 4 words for - ** the helper function, but instead we use the 4 words - ** provided by the function that called us (we don't need to - ** save our argument registers). So what *appears* to be - ** allocating only 40 bytes is actually allocating 56, by - ** using the caller's 16 bytes. - ** - ** The helper routine returns a value that is passed on as the - ** return value from the blocking routine. Since we don't - ** touch $2 between the helper's return and the end of - ** function, we get this behavior for free. - */ -qt_blocki: - sub $sp,$sp,40 /* Allocate reg save space. */ - sw $16, 0+16($sp) - sw $17, 4+16($sp) - sw $18, 8+16($sp) - sw $19,12+16($sp) - sw $20,16+16($sp) - sw $21,20+16($sp) - sw $22,24+16($sp) - sw $23,28+16($sp) - sw $30,32+16($sp) - sw $31,36+16($sp) - add $2, $sp,$0 /* $2 <= old sp to pass to func@$4. */ -qt_abort: - add $sp, $7,$0 /* $sp <= new sp. */ - .set noreorder - jal $31,$4 /* Call helper func@$4 . */ - add $4, $2,$0 /* $a0 <= pass old sp as a parameter. */ - .set reorder - lw $31,36+16($sp) /* Restore callee-save regs... */ - lw $30,32+16($sp) - lw $23,28+16($sp) - lw $22,24+16($sp) - lw $21,20+16($sp) - lw $20,16+16($sp) - lw $19,12+16($sp) - lw $18, 8+16($sp) - lw $17, 4+16($sp) - lw $16, 0+16($sp) /* Restore callee-save */ - - add $sp,$sp,40 /* Deallocate reg save space. */ - j $31 /* Return to caller. */ - - /* - ** Non-varargs thread startup. - ** Note: originally, 56 bytes were allocated on the stack. - ** The thread restore routine (_blocki/_abort) removed 40 - ** of them, which means there is still 16 bytes for the - ** argument area required by the MIPS calling convention. - */ -qt_start: - add $4, $16,$0 /* Load up user function pu. */ - add $5, $17,$0 /* ... user function pt. */ - add $6, $18,$0 /* ... user function userf. */ - jal $31,$19 /* Call `only'. */ - j qt_error - - - /* - ** Save calle-save floating-point regs $f20-$f30 - ** See comment in `qt_block' about calling conventinos and - ** reserved space. Use the same trick here, but here we - ** actually have to allocate all the bytes since we have to - ** leave 4 words leftover for `qt_blocki'. - ** - ** Return value from `qt_block' is the same as the return from - ** `qt_blocki'. We get that for free since we don't touch $2 - ** between the return from `qt_blocki' and the return from - ** `qt_block'. - */ -qt_block: - sub $sp, $sp,56 /* 6 8-byte regs, saved ret pc, aligned. */ - swc1 $f20, 0+16($sp) - swc1 $f22, 8+16($sp) - swc1 $f24, 16+16($sp) - swc1 $f26, 24+16($sp) - swc1 $f28, 32+16($sp) - swc1 $f30, 40+16($sp) - sw $31, 48+16($sp) - jal qt_blocki - lwc1 $f20, 0+16($sp) - lwc1 $f22, 8+16($sp) - lwc1 $f24, 16+16($sp) - lwc1 $f26, 24+16($sp) - lwc1 $f28, 32+16($sp) - lwc1 $f30, 40+16($sp) - lw $31, 48+16($sp) - add $sp, $sp,56 - j $31 - - - /* - ** First, call `startup' with the `pt' argument. - ** - ** Next, call the user's function with all arguments. - ** Note that we don't know whether args were passed in - ** integer regs, fp regs, or on the stack (See Gerry Kane - ** "MIPS R2000 RISC Architecture" pg D-22), so we reload - ** all the registers, possibly with garbage arguments. - ** - ** Finally, call `cleanup' with the `pt' argument and with - ** the return value from the user's function. It is an error - ** for `cleanup' to return. - */ -qt_vstart: - add $4, $17,$0 /* `pt' is arg0 to `startup'. */ - jal $31, $18 /* Call `startup'. */ - - add $sp, $sp,16 /* Free extra save space. */ - lw $4, 0($sp) /* Load up args. */ - lw $5, 4($sp) - lw $6, 8($sp) - lw $7, 12($sp) - lwc1 $f12, 0($sp) /* Load up fp args. */ - lwc1 $f14, 8($sp) - jal $31,$19 /* Call `userf'. */ - - add $4, $17,$0 /* `pt' is arg0 to `cleanup'. */ - add $5, $2,$0 /* Ret. val is arg1 to `cleanup'. */ - jal $31, $16 /* Call `cleanup'. */ - - j qt_error diff --git a/qt/md/mips_b.s b/qt/md/mips_b.s deleted file mode 100644 index 5b3740843..000000000 --- a/qt/md/mips_b.s +++ /dev/null @@ -1,99 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - - .globl b_call_reg - .globl b_call_imm - .globl b_add - .globl b_load - - .ent b_null -b_null: - j $31 - .end b_null - - .ent b_call_reg -b_call_reg: - la $5,b_null - add $6, $31,0 -$L0: - jal $5 - jal $5 - jal $5 - jal $5 - jal $5 - - sub $4, $4,5 - bgtz $4,$L0 - j $6 - .end - - - .ent b_call_imm -b_call_imm: - add $6, $31,0 -$L1: - jal b_null - jal b_null - jal b_null - jal b_null - jal b_null - - sub $4, $4,5 - bgtz $4,$L1 - j $6 - .end - - - .ent b_add -b_add: - add $5, $0,$4 - add $6, $0,$4 - add $7, $0,$4 - add $8, $0,$4 -$L2: - sub $4, $4,5 - sub $5, $5,5 - sub $6, $6,5 - sub $7, $7,5 - sub $8, $8,5 - - sub $4, $4,5 - sub $5, $5,5 - sub $6, $6,5 - sub $7, $7,5 - sub $8, $8,5 - - bgtz $4,$L2 - j $31 - .end - - - .ent b_load -b_load: -$L3: - ld $0, 0($sp) - ld $0, 4($sp) - ld $0, 8($sp) - ld $0, 12($sp) - ld $0, 16($sp) - - ld $0, 20($sp) - ld $0, 24($sp) - ld $0, 28($sp) - ld $0, 32($sp) - ld $0, 36($sp) - - sub $4, $4,10 - bgtz $4,$L3 - j $31 - .end diff --git a/qt/md/null.README b/qt/md/null.README deleted file mode 100644 index e69de29bb..000000000 --- a/qt/md/null.README +++ /dev/null diff --git a/qt/md/null.c b/qt/md/null.c deleted file mode 100644 index 775db62be..000000000 --- a/qt/md/null.c +++ /dev/null @@ -1,14 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -char const qtmd_rcsid[] = "$Header: /home/ludo/src/guile.cvs/gitification/guile-cvs/guile/guile-core/qt/md/null.c,v 1.1 1996-10-01 03:34:16 mdj Exp $"; diff --git a/qt/md/solaris.README b/qt/md/solaris.README deleted file mode 100644 index 04f855c44..000000000 --- a/qt/md/solaris.README +++ /dev/null @@ -1,19 +0,0 @@ -Solaris 2.x is like System V (maybe it *is* System V?) and is different -from older versions in that it uses no leading underscore for variable -and function names. That is, the old convention was: - - foo(){} - -got compiled as - - .globl _foo - _foo: - -and is now compiled as - - .globl foo - foo: - -The `config' script should fix up the older (leading underscore) versions -of the machine-dependent files to use the newer (no leading underscore) -calling conventions. diff --git a/qt/md/sparc.h b/qt/md/sparc.h deleted file mode 100644 index e2ab281b4..000000000 --- a/qt/md/sparc.h +++ /dev/null @@ -1,140 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -#ifndef QT_SPARC_H -#define QT_SPARC_H - -typedef unsigned long qt_word_t; - -/* Stack layout on the sparc: - - non-varargs: - - +--- - | <blank space for alignment> - | %o7 == return address -> qt_start - | %i7 - | %i6 == frame pointer -> 0 (NULL-terminated stack frame chain) - | %i5 -> only - | %i4 -> userf - | %i3 - | %i2 -> pt - | %i1 -> pu - | %i0 - | %l7 - | %l6 - | %l5 - | %l4 - | %l3 - | %l2 - | %l1 - | %l0 <--- qt_t.sp - +--- - - varargs: - - | : - | : - | argument list - | one-word aggregate return pointer - +--- - | <blank space for alignment> - | %o7 == return address -> qt_vstart - | %i7 - | %i6 == frame pointer -> 0 (NULL-terminated stack frame chain) - | %i5 -> startup - | %i4 -> userf - | %i3 -> cleanup - | %i2 -> pt - | %i1 - | %i0 - | %l7 - | %l6 - | %l5 - | %l4 - | %l3 - | %l2 - | %l1 - | %l0 <--- qt_t.sp - +--- - - */ - - -/* What to do to start a thread running. */ -extern void qt_start (void); -extern void qt_vstart (void); - - -/* Hold 17 saved registers + 1 word for alignment. */ -#define QT_STKBASE (18 * 4) -#define QT_VSTKBASE QT_STKBASE - - -/* Stack must be doubleword aligned. */ -#define QT_STKALIGN (8) /* Doubleword aligned. */ - -#define QT_ONLY_INDEX (QT_I5) -#define QT_USER_INDEX (QT_I4) -#define QT_ARGT_INDEX (QT_I2) -#define QT_ARGU_INDEX (QT_I1) - -#define QT_VSTARTUP_INDEX (QT_I5) -#define QT_VUSERF_INDEX (QT_I4) -#define QT_VCLEANUP_INDEX (QT_I3) -#define QT_VARGT_INDEX (QT_I2) - -#define QT_O7 (16) -#define QT_I6 (14) -#define QT_I5 (13) -#define QT_I4 (12) -#define QT_I3 (11) -#define QT_I2 (10) -#define QT_I1 ( 9) - - -/* The thread will ``return'' to the `qt_start' routine to get things - going. The normal return sequence takes us to QT_O7+8, so we - pre-subtract 8. The frame pointer chain is 0-terminated to prevent - the trap handler from chasing off in to random memory when flushing - stack windows. */ - -#define QT_ARGS_MD(top) \ - (QT_SPUT ((top), QT_O7, ((void *)(((int)qt_start)-8))), \ - QT_SPUT ((top), QT_I6, 0)) - - -/* The varargs startup routine always reads 6 words of arguments - (6 argument registers) from the stack, offset by one word to - allow for an aggregate return area pointer. If the varargs - routine actually pushed fewer words than that, qt_vstart could read - off the top of the stack. To prevent errors, we always allocate 8 - words. The space is often just wasted. */ - -#define QT_VARGS_MD0(sp, vabytes) \ - ((qt_t *)(((char *)(sp)) - 8*4 - QT_STKROUNDUP(vabytes))) - -#define QT_VARGS_MD1(sp) \ - (QT_SPUT (sp, QT_O7, ((void *)(((int)qt_vstart)-8)))) - -/* The SPARC has wierdo calling conventions which stores a hidden - parameter for returning aggregate values, so the rest of the - parameters are shoved up the stack by one place. */ -#define QT_VARGS_ADJUST(sp) (((char *)sp)+4) - -#define QT_VARGS_DEFAULT - - -#define QT_GROW_DOWN - -#endif /* ndef QT_SPARC_H */ diff --git a/qt/md/sparc.s b/qt/md/sparc.s deleted file mode 100644 index d9bdf0c58..000000000 --- a/qt/md/sparc.s +++ /dev/null @@ -1,142 +0,0 @@ -/* sparc.s -- assembly support for the `qt' thread building kit. */ - -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -/* #include <machine/trap.h> */ - - .text - .align 4 - .global qt_blocki - .global qt_block - .global qt_abort - .global qt_start - .global qt_vstart - -/* Register assignment: -// %o0: incoming `helper' function to call after cswap -// also used as outgoing sp of old thread (qt_t *) -// %o1, %o2: -// parameters to `helper' function called after cswap -// %o3: sp of new thread -// %o5: tmp used to save old thread sp, while using %o0 -// to call `helper' f() after cswap. -// -// -// Aborting a thread is easy if there are no cached register window -// frames: just switch to the new stack and away we go. If there are -// cached register window frames they must all be written back to the -// old stack before we move to the new stack. If we fail to do the -// writeback then the old stack memory can be written with register -// window contents e.g., after the stack memory has been freed and -// reused. -// -// If you don't believe this, try setting the frame pointer to zero -// once we're on the new stack. This will not affect correctnes -// otherwise because the frame pointer will eventually get reloaded w/ -// the new thread's frame pointer. But it will be zero briefly before -// the reload. You will eventually (100,000 cswaps later on a small -// SPARC machine that I tried) get an illegal instruction trap from -// the kernel trying to flush a cached window to location 0x0. -// -// Solution: flush windows before switching stacks, which invalidates -// all the other register windows. We could do the trap -// conditionally: if we're in the lowest frame of a thread, the fp is -// zero already so we know there's nothing cached. But we expect most -// aborts will be done from a first function that does a `save', so we -// will rarely save anything and always pay the cost of testing to see -// if we should flush. -// -// All floating-point registers are caller-save, so this routine -// doesn't need to do anything to save and restore them. -// -// `qt_block' and `qt_blocki' return the same value as the value -// returned by the helper function. We get this ``for free'' -// since we don't touch the return value register between the -// return from the helper function and return from qt_block{,i}. -*/ - -qt_block: -qt_blocki: - sub %sp, 8, %sp /* Allocate save area for return pc. */ - st %o7, [%sp+64] /* Save return pc. */ -qt_abort: - ta 0x03 /* Save locals and ins. */ - mov %sp, %o5 /* Remember old sp w/o chng ins/locals. */ - sub %o3, 64, %sp /* Allocate kwsa, switch stacks. */ - call %o0, 0 /* Call `helper' routine. */ - mov %o5, %o0 /* Pass old thread to qt_after_t() */ - /* .. along w/ args in %o1 & %o2. */ - - /* Restore callee-save regs. The kwsa - // is on this stack, so offset all - // loads by sizeof(kwsa), 64 bytes. - */ - ldd [%sp+ 0+64], %l0 - ldd [%sp+ 8+64], %l2 - ldd [%sp+16+64], %l4 - ldd [%sp+24+64], %l6 - ldd [%sp+32+64], %i0 - ldd [%sp+40+64], %i2 - ldd [%sp+48+64], %i4 - ldd [%sp+56+64], %i6 - ld [%sp+64+64], %o7 /* Restore return pc. */ - - retl /* Return to address in %o7. */ - add %sp, 72, %sp /* Deallocate kwsa, ret pc area. */ - - -/* The function calling conventions say there has to be a 1-word area -// in the caller's stack to hold a pointer to space for aggregate -// return values. It also says there should be a 6-word area to hold -// %o0..%o5 if the callee wants to save them (why? I don't know...) -// Round up to 8 words to maintain alignment. -// -// Parameter values were stored in callee-save regs and are moved to -// the parameter registers. -*/ -qt_start: - mov %i1, %o0 /* `pu': Set up args to `only'. */ - mov %i2, %o1 /* `pt'. */ - mov %i4, %o2 /* `userf'. */ - call %i5, 0 /* Call client function. */ - sub %sp, 32, %sp /* Allocate 6-word callee space. */ - - call qt_error, 0 /* `only' erroniously returned. */ - nop - - -/* Same comments as `qt_start' about allocating rounded-up 7-word -// save areas. */ - -qt_vstart: - sub %sp, 32, %sp /* Allocate 7-word callee space. */ - call %i5, 0 /* call `startup'. */ - mov %i2, %o0 /* .. with argument `pt'. */ - - add %sp, 32, %sp /* Use 7-word space in varargs. */ - ld [%sp+ 4+64], %o0 /* Load arg0 ... */ - ld [%sp+ 8+64], %o1 - ld [%sp+12+64], %o2 - ld [%sp+16+64], %o3 - ld [%sp+20+64], %o4 - call %i4, 0 /* Call `userf'. */ - ld [%sp+24+64], %o5 - - /* Use 6-word space in varargs. */ - mov %o0, %o1 /* Pass return value from userf */ - call %i3, 0 /* .. when call `cleanup. */ - mov %i2, %o0 /* .. along with argument `pt'. */ - - call qt_error, 0 /* `cleanup' erroniously returned. */ - nop diff --git a/qt/md/sparc_b.s b/qt/md/sparc_b.s deleted file mode 100644 index 08351d76d..000000000 --- a/qt/md/sparc_b.s +++ /dev/null @@ -1,106 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - - .globl b_call_reg - .globl b_call_imm - .globl b_add - .globl b_load - -b_null: - retl - nop - -b_call_reg: - sethi %hi(b_null),%o4 - or %o4,%lo(b_null),%o4 - add %o7,%g0, %o3 -L0: - call %o4 - nop - call %o4 - nop - call %o4 - nop - call %o4 - nop - call %o4 - nop - - subcc %o0,1,%o0 - bg L0 - nop - add %o3,%g0, %o7 - retl - nop - -b_call_imm: - sethi %hi(b_null),%o4 - or %o4,%lo(b_null),%o4 - add %o7,%g0, %o3 -L1: - call b_null - call b_null - call b_null - call b_null - call b_null - - subcc %o0,1,%o0 - bg L0 - nop - add %o3,%g0, %o7 - retl - nop - - -b_add: - add %o0,%g0,%o1 - add %o0,%g0,%o2 - add %o0,%g0,%o3 - add %o0,%g0,%o4 -L2: - sub %o0,5,%o0 - sub %o1,5,%o1 - sub %o2,5,%o2 - sub %o3,5,%o3 - sub %o4,5,%o4 - - subcc %o0,5,%o0 - sub %o1,5,%o1 - sub %o2,5,%o2 - sub %o3,5,%o3 - sub %o4,5,%o4 - - bg L2 - nop - retl - nop - - -b_load: - ld [%sp+ 0], %g0 -L3: - ld [%sp+ 4],%g0 - ld [%sp+ 8],%g0 - ld [%sp+12],%g0 - ld [%sp+16],%g0 - ld [%sp+20],%g0 - ld [%sp+24],%g0 - ld [%sp+28],%g0 - ld [%sp+32],%g0 - ld [%sp+36],%g0 - - subcc %o0,10,%o0 - bg L3 - ld [%sp+ 0],%g0 - retl - nop diff --git a/qt/md/vax.h b/qt/md/vax.h deleted file mode 100644 index 1a5af0f2b..000000000 --- a/qt/md/vax.h +++ /dev/null @@ -1,130 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -#ifndef QT_VAX_H -#define QT_VAX_H - -typedef unsigned long qt_word_t; - -/* Thread's initial stack layout on the VAX: - - non-varargs: - - +--- - | arg[2] === `userf' on startup - | arg[1] === `pt' on startup - | arg[0] === `pu' on startup - | ... === `only' on startup. - +--- - | ret pc === `qt_start' on startup - | fp === 0 on startup - | ap === 0 on startup - | <mask> - | 0 (handler) <--- qt_t.sp - +--- - - When a non-varargs thread is started, it ``returns'' to the start - routine, which calls the client's `only' function. - - The varargs case is clearly bad code. The various values should be - stored in a save area and snarfed in to callee-save registers on - startup. However, it's too painful to figure out the register - mask (right now), so do it the slow way. - - +--- - | arg[n-1] - | .. - | arg[0] - | nargs - +--- - | === `cleanup' - | === `vuserf' - | === `startup' - | === `pt' - +--- - | ret pc === `qt_start' on startup - | fp === 0 on startup - | ap === 0 on startup - | <mask> - | 0 (handler) <--- qt_t.sp - +--- - - When a varargs thread is started, it ``returns'' to the `qt_vstart' - startup code. The startup code pops all the extra arguments, then - calls the appropriate functions. */ - - -/* What to do to start a thread running. */ -extern void qt_start (void); -extern void qt_vstart (void); - - -/* Initial call frame for non-varargs and varargs cases. */ -#define QT_STKBASE (10 * 4) -#define QT_VSTKBASE (9 * 4) - - -/* Stack "must be" 4-byte aligned. (Actually, no, but it's - easiest and probably fastest to do so.) */ - -#define QT_STKALIGN (4) - - -/* Where to place various arguments. */ -#define QT_ONLY_INDEX (5) -#define QT_USER_INDEX (8) -#define QT_ARGT_INDEX (7) -#define QT_ARGU_INDEX (6) - -#define QT_VSTARTUP_INDEX (6) -#define QT_VUSERF_INDEX (7) -#define QT_VCLEANUP_INDEX (8) -#define QT_VARGT_INDEX (5) - - -/* Stack grows down. The top of the stack is the first thing to - pop off (predecrement, postincrement). */ -#define QT_GROW_DOWN - - -extern void qt_error (void); - -#define QT_VAX_GMASK_NOREGS (0) - -/* Push on the error return address, null termination to call chains, - number of arguments to `only', register save mask (save no - registers). */ - -#define QT_ARGS_MD(sto) \ - (QT_SPUT (sto, 0, 0), \ - QT_SPUT (sto, 1, QT_VAX_GMASK_NOREGS), \ - QT_SPUT (sto, 2, 0), \ - QT_SPUT (sto, 3, 0), \ - QT_SPUT (sto, 4, qt_start)) - -#define QT_VARGS_MD0(sto, nbytes) \ - (QT_SPUT (sto, (-(nbytes)/4)-1, (nbytes)/4), \ - ((char *)(((sto)-4) - QT_STKROUNDUP(nbytes)))) - -#define QT_VARGS_ADJUST(sp) ((char *)sp + 4) - -#define QT_VARGS_MD1(sto) \ - (QT_SPUT (sto, 0, 0), \ - QT_SPUT (sto, 1, QT_VAX_GMASK_NOREGS), \ - QT_SPUT (sto, 2, 0), \ - QT_SPUT (sto, 3, 0), \ - QT_SPUT (sto, 4, qt_vstart)) - -#define QT_VARGS_DEFAULT - -#endif /* QT_VAX_H */ diff --git a/qt/md/vax.s b/qt/md/vax.s deleted file mode 100644 index fed03f043..000000000 --- a/qt/md/vax.s +++ /dev/null @@ -1,69 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - - .text - - .globl _qt_abort - .globl _qt_block - .globl _qt_blocki - .globl _qt_start - .globl _qt_vstart - - -/* -// Calls to these routines have the signature -// -// void *block (func, arg1, arg2, newsp) -// -// Since the prologue saves 5 registers, nargs, pc, fp, ap, mask, and -// a condition handler (at sp+0), the first argument is 40=4*10 bytes -// offset from the stack pointer. -*/ -_qt_block: -_qt_blocki: -_qt_abort: - .word 0x7c0 /* Callee-save mask: 5 registers. */ - movl 56(sp),r1 /* Get stack pointer of new thread. */ - movl 52(sp),-(r1) /* Push arg2 */ - movl 48(sp),-(r1) /* Push arg1 */ - movl sp,-(r1) /* Push arg0 */ - - movl 44(sp),r0 /* Get helper to call. */ - movl r1,sp /* Move to new thread's stack. */ - addl3 sp,$12,fp /* .. including the frame pointer. */ - calls $3,(r0) /* Call helper. */ - - ret - -_qt_start: - movl (sp)+,r0 /* Get `only'. */ - calls $3,(r0) /* Call `only'. */ - calls $0,_qt_error /* `only' erroniously returned. */ - - -_qt_vstart: - movl (sp)+,r10 /* Get `pt'. */ - movl (sp)+,r9 /* Get `startup'. */ - movl (sp)+,r8 /* Get `vuserf'. */ - movl (sp)+,r7 /* Get `cleanup'. */ - - pushl r10 /* Push `qt'. */ - calls $1,(r9) /* Call `startup', pop `qt' on return. */ - - calls (sp)+,(r8) /* Call user's function. */ - - pushl r0 /* Push `vuserf_retval'. */ - pushl r10 /* Push `qt'. */ - calls $2,(r7) /* Call `cleanup', never return. */ - - calls $0,_qt_error /* `cleanup' erroniously returned. */ diff --git a/qt/md/vax_b.s b/qt/md/vax_b.s deleted file mode 100644 index 2db2d4fec..000000000 --- a/qt/md/vax_b.s +++ /dev/null @@ -1,92 +0,0 @@ -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - - .text - .globl _b_call_reg - .globl _b_call_imm - .globl _b_add - .globl _b_load - -_b_null: - .word 0x0 - ret - -_b_call_reg: - .word 0x0 - movl 4(ap),r0 - moval _b_null,r1 -L0: - calls $0,(r1) - calls $0,(r1) - calls $0,(r1) - calls $0,(r1) - calls $0,(r1) - - subl2 $5,r0 - bgtr L0 - ret - - -_b_call_imm: - .word 0x0 - movl 4(ap),r0 -L1: - calls $0,_b_null - calls $0,_b_null - calls $0,_b_null - calls $0,_b_null - calls $0,_b_null - - subl2 $5,r0 - bgtr L1 - ret - - -_b_add: - .word 0x0 - movl 4(ap),r0 -L2: - subl2 $1,r0 - subl2 $1,r0 - subl2 $1,r0 - subl2 $1,r0 - subl2 $1,r0 - - subl2 $1,r0 - subl2 $1,r0 - subl2 $1,r0 - subl2 $1,r0 - subl2 $1,r0 - - bgtr L2 - ret - - -_b_load: - .word 0x0 - movl 4(ap),r0 -L3: - movl 0(sp),r1 - movl 4(sp),r1 - movl 8(sp),r1 - movl 12(sp),r1 - movl 16(sp),r1 - movl 20(sp),r1 - movl 24(sp),r1 - movl 28(sp),r1 - movl 32(sp),r1 - movl 36(sp),r1 - - subl2 $1,r0 - bgtr L3 - ret diff --git a/qt/meas.c b/qt/meas.c deleted file mode 100644 index 3faab3c52..000000000 --- a/qt/meas.c +++ /dev/null @@ -1,1049 +0,0 @@ -/* meas.c -- measure qt stuff. */ - -#include "copyright.h" - -/* Need this to get assertions under Mach on the Sequent/i386: */ -#ifdef __i386__ -#define assert(ex) \ - do { \ - if (!(ex)) { \ - fprintf (stderr, "[%s:%d] Assertion " #ex " failed\n", __FILE__, __LINE__); \ - abort(); \ - } \ - } while (0) -#else -#include <assert.h> -#endif - -/* This really ought to be defined in some ANSI include file (*I* - think...), but it's defined here instead, which leads us to another - machine dependency. - - The `iaddr_t' type is an integer representation of a pointer, - suited for doing arithmetic on addresses, e.g. to round an address - to an alignment boundary. */ -typedef unsigned long iaddr_t; - -#include <stdarg.h> /* For varargs tryout. */ -#include <stdio.h> -#include "b.h" -#include "qt.h" -#include "stp.h" - -extern void exit (int status); -extern int atoi (char const *s); -extern int fprintf (FILE *out, char const *fmt, ...); -extern int fputs (char const *s, FILE *fp); -extern void free (void *sto); -extern void *malloc (unsigned nbytes); -extern void perror (char const *s); - -void usage (void); -void tracer(void); - -/* Round `v' to be `a'-aligned, assuming `a' is a power of two. */ -#define ROUND(v, a) (((v) + (a) - 1) & ~((a)-1)) - -typedef struct thread_t { - qt_t *qt; /* Pointer to thread of function... */ - void *stk; - void *top; /* Set top of stack if reuse. */ - struct thread_t *next; -} thread_t; - - - static thread_t * -t_alloc (void) -{ - thread_t *t; - int ssz = 0x1000; - - t = malloc (sizeof(thread_t)); - if (!t) { - perror ("malloc"); - exit (1); - } - assert (ssz > QT_STKBASE); - t->stk = malloc (ssz); - t->stk = (void *)ROUND (((iaddr_t)t->stk), QT_STKALIGN); - if (!t->stk) { - perror ("malloc"); - exit (1); - } - assert ((((iaddr_t)t->stk) & (QT_STKALIGN-1)) == 0); - t->top = QT_SP (t->stk, ssz - QT_STKBASE); - - return (t); -} - - - static thread_t * -t_create (qt_only_t *starter, void *p0, qt_userf_t *f) -{ - thread_t *t; - - t = t_alloc(); - t->qt = QT_ARGS (t->top, p0, t, f, starter); - return (t); -} - - - static void -t_free (thread_t *t) -{ - free (t->stk); - free (t); -} - - - static void * -t_null (qt_t *old, void *p1, void *p2) -{ - /* return (garbage); */ -} - - - static void * -t_splat (qt_t *old, void *oldp, void *null) -{ - *(qt_t **)oldp = old; - /* return (garbage); */ -} - - -static char const test01_msg[] = - "*QT_SP(sto,sz), QT_ARGS(top,p0,p1,userf,first)"; - -static char const *test01_descr[] = { - "Performs 1 QT_SP and one QT_ARGS per iteration.", - NULL -}; - -/* This test gives a guess on how long it takes to initalize - a thread. */ - - static void -test01 (int n) -{ - char stack[QT_STKBASE+QT_STKALIGN]; - char *stk; - qt_t *top; - - stk = (char *)ROUND (((iaddr_t)stack), QT_STKALIGN); - - { - int i; - - for (i=0; i<QT_STKBASE; ++i) { - stk[i] = 0; - } - } - - while (n>0) { - /* RETVALUSED */ - top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0); -#ifdef NDEF - top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0); - top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0); - top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0); - top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0); - - top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0); - top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0); - top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0); - top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0); - top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0); - - n -= 10; -#else - n -= 1; -#endif - } -} - - -static char const test02_msg[] = "QT_BLOCKI (0, 0, test02_aux, t->qt)"; -static qt_t *rootthread; - - static void -test02_aux1 (void *pu, void *pt, qt_userf_t *f) -{ - QT_ABORT (t_null, 0, 0, rootthread); -} - - static void * -test02_aux2 (qt_t *old, void *farg1, void *farg2) -{ - rootthread = old; - /* return (garbage); */ -} - - static void -test02 (int n) -{ - thread_t *t; - - while (n>0) { - t = t_create (test02_aux1, 0, 0); - QT_BLOCKI (test02_aux2, 0, 0, t->qt); - t_free (t); - t = t_create (test02_aux1, 0, 0); - QT_BLOCKI (test02_aux2, 0, 0, t->qt); - t_free (t); - t = t_create (test02_aux1, 0, 0); - QT_BLOCKI (test02_aux2, 0, 0, t->qt); - t_free (t); - t = t_create (test02_aux1, 0, 0); - QT_BLOCKI (test02_aux2, 0, 0, t->qt); - t_free (t); - t = t_create (test02_aux1, 0, 0); - QT_BLOCKI (test02_aux2, 0, 0, t->qt); - t_free (t); - - n -= 5; - } -} - - -static char const test03_msg[] = "QT_BLOCKI (...) test vals are right."; - - -/* Called by the thread function when it wants to shut down. - Return a value to the main thread. */ - - static void * -test03_aux0 (qt_t *old_is_garbage, void *farg1, void *farg2) -{ - assert (farg1 == (void *)5); - assert (farg2 == (void *)6); - return ((void *)15); /* Some unlikely value. */ -} - - -/* Called during new thread startup by main thread. Since the new - thread has never run before, return value is ignored. */ - - static void * -test03_aux1 (qt_t *old, void *farg1, void *farg2) -{ - assert (old != NULL); - assert (farg1 == (void *)5); - assert (farg2 == (void *)6); - rootthread = old; - return ((void *)16); /* Different than `15'. */ -} - - static void -test03_aux2 (void *pu, void *pt, qt_userf_t *f) -{ - assert (pu == (void *)1); - assert (f == (qt_userf_t *)4); - QT_ABORT (test03_aux0, (void *)5, (void *)6, rootthread); -} - - static void -test03 (int n) -{ - thread_t *t; - void *rv; - - while (n>0) { - t = t_create (test03_aux2, (void *)1, (qt_userf_t *)4); - rv = QT_BLOCKI (test03_aux1, (void *)5, (void *)6, t->qt); - assert (rv == (void *)15); - t_free (t); - - --n; - } -} - - -static char const test04_msg[] = "stp_start w/ no threads."; - - static void -test04 (int n) -{ - while (n>0) { - stp_init(); stp_start(); - stp_init(); stp_start(); - stp_init(); stp_start(); - stp_init(); stp_start(); - stp_init(); stp_start(); - - stp_init(); stp_start(); - stp_init(); stp_start(); - stp_init(); stp_start(); - stp_init(); stp_start(); - stp_init(); stp_start(); - - n -= 10; - } -} - - -static char const test05_msg[] = "stp w/ 2 yielding thread."; - - static void -test05_aux (void *null) -{ - stp_yield(); - stp_yield(); -} - - static void -test05 (int n) -{ - while (n>0) { - stp_init(); - stp_create (test05_aux, 0); - stp_create (test05_aux, 0); - stp_start(); - - --n; - } -} - - -static char const test06_msg[] = "*QT_ARGS(...), QT_BLOCKI one thread"; - -static char const *test06_descr[] = { - "Does a QT_ARGS, QT_BLOCKI to a helper function that saves the", - "stack pointer of the main thread, calls an `only' function that", - "saves aborts the thread, calling a null helper function.", - ":: start/stop = QT_ARGS + QT_BLOCKI + QT_ABORT + 3 procedure calls.", - NULL -}; - -/* This test initializes a thread, runs it, then returns to the main - program, which reinitializes the thread, runs it again, etc. Each - iteration corresponds to 1 init, 1 abort, 1 block. */ - -static qt_t *test06_sp; - - - static void -test06_aux2 (void *null0a, void *null1b, void *null2b, qt_userf_t *null) -{ - QT_ABORT (t_null, 0, 0, test06_sp); -} - - - static void * -test06_aux3 (qt_t *sp, void *null0c, void *null1c) -{ - test06_sp = sp; - /* return (garbage); */ -} - - - static void -test06 (int n) -{ - thread_t *t; - - t = t_create (0, 0, 0); - - while (n>0) { - /* RETVALUSED */ - QT_ARGS (t->top, 0, 0, 0, test06_aux2); - QT_BLOCKI (test06_aux3, 0, 0, t->qt); -#ifdef NDEF - /* RETVALUSED */ - QT_ARGS (t->top, 0, 0, 0, test06_aux2); - QT_BLOCKI (test06_aux3, 0, 0, t->qt); - - /* RETVALUSED */ - QT_ARGS (t->top, 0, 0, 0, test06_aux2); - QT_BLOCKI (test06_aux3, 0, 0, t->qt); - - /* RETVALUSED */ - QT_ARGS (t->top, 0, 0, 0, test06_aux2); - QT_BLOCKI (test06_aux3, 0, 0, t->qt); - - /* RETVALUSED */ - QT_ARGS (t->top, 0, 0, 0, test06_aux2); - QT_BLOCKI (test06_aux3, 0, 0, t->qt); - - n -= 5; -#else - --n; -#endif - } -} - -static char test07_msg[] = "*cswap between threads"; - -static char const *test07_descr[] = { - "Build a chain of threads where each thread has a fixed successor.", - "There is no scheduling performed. Each thread but one is a loop", - "that simply blocks with QT_BLOCKI, calling a helper that saves the", - "current stack pointer. The last thread decrements a count, and,", - "if zero, aborts back to the main thread. Else it continues with", - "the blocking chain. The count is divided by the number of threads", - "in the chain, so `n' is the number of integer block operations.", - ":: integer cswap = QT_BLOCKI + a procedure call.", - NULL -}; - -/* This test repeatedly blocks a bunch of threads. - Each iteration corresponds to one block operation. - - The threads are arranged so that there are TEST07_N-1 of them that - run `test07_aux2'. Each one of those blocks saving it's sp to - storage owned by the preceding thread; a pointer to that storage is - passed in via `mep'. Each thread has a handle on it's own storage - for the next thread, referenced by `nxtp', and it blocks by passing - control to `*nxtp', telling the helper function to save its state - in `*mep'. The last thread in the chain decrements a count and, if - it's gone below zero, returns to `test07'; otherwise, it invokes - the first thread in the chain. */ - -static qt_t *test07_heavy; - -#define TEST07_N (4) - - - static void -test07_aux2 (void *null0, void *mep, void *nxtp, qt_userf_t *null) -{ - qt_t *nxt; - - while (1) { - nxt = *(qt_t **)nxtp; -#ifdef NDEF - printf ("Helper 0x%p\n", nxtp); -#endif - QT_BLOCKI (t_splat, mep, 0, nxt); - } -} - - static void -test07_aux3 (void *np, void *mep, void *nxtp, qt_userf_t *null) -{ - int n; - - n = *(int *)np; - while (1) { - n -= TEST07_N; - if (n<0) { - QT_ABORT (t_splat, mep, 0, test07_heavy); - } - QT_BLOCKI (t_splat, mep, 0, *(qt_t **)nxtp); - } -} - - - static void -test07 (int n) -{ - int i; - thread_t *t[TEST07_N]; - - for (i=0; i<TEST07_N; ++i) { - t[i] = t_create (0, 0, 0); - } - for (i=0; i<TEST07_N-1; ++i) { - /* RETVALUSED */ - QT_ARGS (t[i]->top, 0, &t[i]->qt, &t[i+1]->qt, test07_aux2); - } - /* RETVALUSED */ - QT_ARGS (t[i]->top, &n, &t[TEST07_N-1]->qt, &t[0]->qt, test07_aux3); - QT_BLOCKI (t_splat, &test07_heavy, 0, t[0]->qt); -} - - -static char test08_msg[] = "Floating-point cswap between threads"; - -static char const *test08_descr[] = { - "Measure context switch times including floating-point, use QT_BLOCK.", - NULL -}; - -static qt_t *test08_heavy; - -#define TEST08_N (4) - - - static void -test08_aux2 (void *null0, void *mep, void *nxtp, qt_userf_t *null) -{ - qt_t *nxt; - - while (1) { - nxt = *(qt_t **)nxtp; - QT_BLOCK (t_splat, mep, 0, nxt); - } -} - - static void -test08_aux3 (void *np, void *mep, void *nxtp, qt_userf_t *null) -{ - int n; - - n = *(int *)np; - while (1) { - n -= TEST08_N; - if (n<0) { - QT_ABORT (t_splat, mep, 0, test08_heavy); - } - QT_BLOCK (t_splat, mep, 0, *(qt_t **)nxtp); - } -} - - - static void -test08 (int n) -{ - int i; - thread_t *t[TEST08_N]; - - for (i=0; i<TEST08_N; ++i) { - t[i] = t_create (0, 0, 0); - } - for (i=0; i<TEST08_N-1; ++i) { - /* RETVALUSED */ - QT_ARGS (t[i]->top, 0, &t[i]->qt, &t[i+1]->qt, test08_aux2); - } - /* RETVALUSED */ - QT_ARGS (t[i]->top, &n, &t[TEST08_N-1]->qt, &t[0]->qt, test08_aux3); - QT_BLOCK (t_splat, &test08_heavy, 0, t[0]->qt); -} - - -/* Test the varargs procedure calling. */ - -char const test09_msg[] = { "Start and run threads using varargs." }; - -thread_t *test09_t0, *test09_t1, *test09_t2, *test09_main; - - thread_t * -test09_create (qt_startup_t *start, qt_vuserf_t *f, - qt_cleanup_t *cleanup, int nbytes, ...) -{ - va_list ap; - thread_t *t; - - t = t_alloc(); - va_start (ap, nbytes); - t->qt = QT_VARGS (t->top, nbytes, ap, t, start, f, cleanup); - va_end (ap); - return (t); -} - - - static void -test09_cleanup (void *pt, void *vuserf_retval) -{ - assert (vuserf_retval == (void *)17); - QT_ABORT (t_splat, &((thread_t *)pt)->qt, 0, - ((thread_t *)pt)->next->qt); -} - - - static void -test09_start (void *pt) -{ -} - - - static void * -test09_user0 (void) -{ - QT_BLOCKI (t_splat, &test09_t0->qt, 0, test09_t1->qt); - return ((void *)17); -} - - static void * -test09_user2 (int one, int two) -{ - assert (one == 1); - assert (two == 2); - QT_BLOCKI (t_splat, &test09_t1->qt, 0, test09_t2->qt); - assert (one == 1); - assert (two == 2); - return ((void *)17); -} - - static void * -test09_user10 (int one, int two, int three, int four, int five, - int six, int seven, int eight, int nine, int ten) -{ - assert (one == 1); - assert (two == 2); - assert (three == 3); - assert (four == 4); - assert (five == 5); - assert (six == 6); - assert (seven == 7); - assert (eight == 8); - assert (nine == 9); - assert (ten == 10); - QT_BLOCKI (t_splat, &test09_t2->qt, 0, test09_main->qt); - assert (one == 1); - assert (two == 2); - assert (three == 3); - assert (four == 4); - assert (five == 5); - assert (six == 6); - assert (seven == 7); - assert (eight == 8); - assert (nine == 9); - assert (ten == 10); - return ((void *)17); -} - - - void -test09 (int n) -{ - thread_t main; - - test09_main = &main; - - while (--n >= 0) { - test09_t0 = test09_create (test09_start, (qt_vuserf_t*)test09_user0, - test09_cleanup, 0); - test09_t1 = test09_create (test09_start, (qt_vuserf_t*)test09_user2, - test09_cleanup, 2 * sizeof(qt_word_t), 1, 2); - test09_t2 = test09_create (test09_start, (qt_vuserf_t*)test09_user10, - test09_cleanup, 10 * sizeof(qt_word_t), - 1, 2, 3, 4, 5, 6, 7, 8, 9, 10); - - /* Chaining used by `test09_cleanup' to determine who is next. */ - test09_t0->next = test09_t1; - test09_t1->next = test09_t2; - test09_t2->next = test09_main; - - QT_BLOCKI (t_splat, &test09_main->qt, 0, test09_t0->qt); - QT_BLOCKI (t_splat, &test09_main->qt, 0, test09_t0->qt); - - t_free (test09_t0); - t_free (test09_t1); - t_free (test09_t2); - } -} - - -/* Test 10/11/12: time the cost of various number of args. */ - -char const test10_msg[] = { "*Test varargs init & startup w/ 0 args." }; - -char const *test10_descr[] = { - "Start and stop threads that use variant argument lists (varargs).", - "Each thread is initialized by calling a routine that calls", - "QT_VARARGS. Then runs the thread by calling QT_BLOCKI to hald the", - "main thread, a helper that saves the main thread's stack pointer,", - "a null startup function, a null user function, a cleanup function", - "that calls QT_ABORT and restarts the main thread. Copies no user", - "parameters.", - ":: varargs start/stop = QT_BLOCKI + QT_ABORT + 6 function calls.", - NULL -}; - -/* Helper function to send control back to main. - Don't save anything. */ - - -/* Helper function for starting the varargs thread. Save the stack - pointer of the main thread so we can get back there eventually. */ - - -/* Startup function for a varargs thread. */ - - static void -test10_startup (void *pt) -{ -} - - -/* User function for a varargs thread. */ - - static void * -test10_run (int arg0, ...) -{ - /* return (garbage); */ -} - - -/* Cleanup function for a varargs thread. Send control - back to the main thread. Don't save any state from the thread that - is halting. */ - - void -test10_cleanup (void *pt, void *vuserf_retval) -{ - QT_ABORT (t_null, 0, 0, ((thread_t *)pt)->qt); -} - - - void -test10_init (thread_t *new, thread_t *next, int nbytes, ...) -{ - va_list ap; - - va_start (ap, nbytes); - new->qt = QT_VARGS (new->top, nbytes, ap, next, test10_startup, - test10_run, test10_cleanup); - va_end (ap); -} - - - void -test10 (int n) -{ - thread_t main; - thread_t *t; - - t = t_alloc(); - t->next = &main; - - while (--n >= 0) { - test10_init (t, &main, 0); - QT_BLOCKI (t_splat, &main.qt, 0, t->qt); - } - t_free (t); -} - - -char const test11_msg[] = { "*Test varargs init & startup w/ 2 args." }; - -char const *test11_descr[] = { - "Varargs initialization/run. Copies 2 user arguments.", - ":: varargs 2 start/stop = QT_VARGS(2 args), QT_BLOCKI, QT_ABORT, 6 f() calls.", - NULL -}; - - - void -test11 (int n) -{ - thread_t main; - thread_t *t; - - t = t_alloc(); - t->next = &main; - - while (--n >= 0) { - test10_init (t, &main, 2 * sizeof(int), 2, 1); - QT_BLOCKI (t_splat, &main.qt, 0, t->qt); - } - t_free (t); -} - -char const test12_msg[] = { "*Test varargs init & startup w/ 4 args." }; - -char const *test12_descr[] = { - "Varargs initialization/run. Copies 4 user arguments.", - ":: varargs 4 start/stop = QT_VARGS(4 args), QT_BLOCKI, QT_ABORT, 6 f() calls.", - NULL -}; - - - void -test12 (int n) -{ - thread_t main; - thread_t *t; - - t = t_alloc(); - t->next = &main; - - while (--n >= 0) { - test10_init (t, &main, 4 * sizeof(int), 4, 3, 2, 1); - QT_BLOCKI (t_splat, &main.qt, 0, t->qt); - } - t_free (t); -} - - -char const test13_msg[] = { "*Test varargs init & startup w/ 8 args." }; - -char const *test13_descr[] = { - "Varargs initialization/run. Copies 8 user arguments.", - ":: varargs 8 start/stop = QT_VARGS(8 args), QT_BLOCKI, QT_ABORT, 6 f() calls.", - NULL -}; - - void -test13 (int n) -{ - thread_t main; - thread_t *t; - - t = t_alloc(); - t->next = &main; - - while (--n >= 0) { - test10_init (t, &main, 8 * sizeof(int), 8, 7, 6, 5, 4, 3, 2, 1); - QT_BLOCKI (t_splat, &main.qt, 0, t->qt); - } - t_free (t); -} - - -char const test14_msg[] = { "*Test varargs initialization w/ 0 args." }; - -char const *test14_descr[] = { - "Varargs initialization without running the thread. Just calls", - "QT_VARGS.", - ":: varargs 0 init = QT_VARGS()", - NULL -}; - - void -test14 (int n) -{ - thread_t main; - thread_t *t; - - t = t_alloc(); - t->next = &main; - - while (--n >= 0) { - test10_init (t, &main, 0 * sizeof(int)); - } - t_free (t); -} - - -char const test15_msg[] = { "*Test varargs initialization w/ 2 args." }; - -char const *test15_descr[] = { - "Varargs initialization without running the thread. Just calls", - "QT_VARGS.", - ":: varargs 2 init = QT_VARGS(2 args)", - NULL -}; - - void -test15 (int n) -{ - thread_t main; - thread_t *t; - - t = t_alloc(); - t->next = &main; - - while (--n >= 0) { - test10_init (t, &main, 2 * sizeof(int), 2, 1); - } - t_free (t); -} - -char const test16_msg[] = { "*Test varargs initialization w/ 4 args." }; - -char const *test16_descr[] = { - "Varargs initialization without running the thread. Just calls", - "QT_VARGS.", - ":: varargs 4 init = QT_VARGS(4 args)", - NULL -}; - - - void -test16 (int n) -{ - thread_t main; - thread_t *t; - - t = t_alloc(); - t->next = &main; - - while (--n >= 0) { - test10_init (t, &main, 4 * sizeof(int), 4, 3, 2, 1); - } - t_free (t); -} - - -char const test17_msg[] = { "*Test varargs initialization w/ 8 args." }; - -char const *test17_descr[] = { - "Varargs initialization without running the thread. Just calls", - "QT_VARGS.", - ":: varargs 8 init = QT_VARGS(8 args)", - NULL -}; - - - void -test17 (int n) -{ - thread_t main; - thread_t *t; - - t = t_alloc(); - t->next = &main; - - while (--n >= 0) { - test10_init (t, &main, 8 * sizeof(int), 8, 7, 6, 5, 4, 3, 2, 1); - } - t_free (t); -} - -/* Test times for basic machine operations. */ - -char const test18_msg[] = { "*Call register indirect." }; -char const *test18_descr[] = { NULL }; - - void -test18 (int n) -{ - b_call_reg (n); -} - - -char const test19_msg[] = { "*Call immediate." }; -char const *test19_descr[] = { NULL }; - - void -test19 (int n) -{ - b_call_imm (n); -} - - -char const test20_msg[] = { "*Add register-to-register." }; -char const *test20_descr[] = { NULL }; - - void -test20 (int n) -{ - b_add (n); -} - - -char const test21_msg[] = { "*Load memory to a register." }; -char const *test21_descr[] = { NULL }; - - void -test21 (int n) -{ - b_load (n); -} - -/* Driver. */ - -typedef struct foo_t { - char const *msg; /* Message to print for generic help. */ - char const **descr; /* A description of what is done by the test. */ - void (*f)(int n); -} foo_t; - - -static foo_t foo[] = { - { "Usage:\n", NULL, (void(*)(int n))usage }, - { test01_msg, test01_descr, test01 }, - { test02_msg, NULL, test02 }, - { test03_msg, NULL, test03 }, - { test04_msg, NULL, test04 }, - { test05_msg, NULL, test05 }, - { test06_msg, test06_descr, test06 }, - { test07_msg, test07_descr, test07 }, - { test08_msg, test08_descr, test08 }, - { test09_msg, NULL, test09 }, - { test10_msg, test10_descr, test10 }, - { test11_msg, test11_descr, test11 }, - { test12_msg, test12_descr, test12 }, - { test13_msg, test13_descr, test13 }, - { test14_msg, test14_descr, test14 }, - { test15_msg, test15_descr, test15 }, - { test16_msg, test16_descr, test16 }, - { test17_msg, test17_descr, test17 }, - { test18_msg, test18_descr, test18 }, - { test19_msg, test19_descr, test19 }, - { test20_msg, test20_descr, test20 }, - { test21_msg, test21_descr, test21 }, - { 0, 0 } -}; - -static int tv = 0; - - void -tracer () -{ - - fprintf (stderr, "tracer\t%d\n", tv++); - fflush (stderr); -} - - void -tracer2 (void *val) -{ - fprintf (stderr, "tracer2\t%d val=0x%p", tv++, val); - fflush (stderr); -} - - - void -describe() -{ - int i; - FILE *out = stdout; - - for (i=0; foo[i].msg; ++i) { - if (foo[i].descr) { - int j; - - putc ('\n', out); - fprintf (out, "[%d]\n", i); - for (j=0; foo[i].descr[j]; ++j) { - fputs (foo[i].descr[j], out); - putc ('\n', out); - } - } - } - exit (0); -} - - - void -usage() -{ - int i; - - fputs (foo[0].msg, stderr); - for (i=1; foo[i].msg; ++i) { - fprintf (stderr, "%2d\t%s\n", i, foo[i].msg); - } - exit (1); -} - - - void -args (int *which, int *n, int argc, char **argv) -{ - static int nfuncs = 0; - - if (argc == 2 && argv[1][0] == '-' && argv[1][1] == 'h') { - describe(); - } - - if (nfuncs == 0) { - for (nfuncs=0; foo[nfuncs].msg; ++nfuncs) - ; - } - - if (argc != 2 && argc != 3) { - usage(); - } - - *which = atoi (argv[1]); - if (*which < 0 || *which >= nfuncs) { - usage(); - } - *n = (argc == 3) - ? atoi (argv[2]) - : 1; -} - - - int -main (int argc, char **argv) -{ - int which, n; - args (&which, &n, argc, argv); - (*(foo[which].f))(n); - exit (0); - return (0); -} diff --git a/qt/qt.c b/qt/qt.c deleted file mode 100644 index 1e406d24c..000000000 --- a/qt/qt.c +++ /dev/null @@ -1,48 +0,0 @@ -#include "copyright.h" -#include "qt.h" - -#ifdef QT_VARGS_DEFAULT - -/* If the stack grows down, `vargs' is a pointer to the lowest - address in the block of arguments. If the stack grows up, it is a - pointer to the highest address in the block. */ - - qt_t * -qt_vargs (qt_t *sp, int nbytes, void *vargs, - void *pt, qt_startup_t *startup, - qt_vuserf_t *vuserf, qt_cleanup_t *cleanup) -{ - int i; - - sp = QT_VARGS_MD0 (sp, nbytes); -#ifdef QT_GROW_UP - for (i=nbytes/sizeof(qt_word_t); i>0; --i) { - QT_SPUT (QT_VARGS_ADJUST(sp), i, ((qt_word_t *)vargs)[-i]); - } -#else - for (i=nbytes/sizeof(qt_word_t); i>0; --i) { - QT_SPUT (QT_VARGS_ADJUST(sp), i-1, ((qt_word_t *)vargs)[i-1]); - } -#endif - - QT_VARGS_MD1 (QT_VADJ(sp)); - QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt); - QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup); - QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf); - QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup); - return ((qt_t *)QT_VADJ(sp)); -} -#endif /* def QT_VARGS_DEFAULT */ - - void -qt_null (void) -{ -} - - void -qt_error (void) -{ - extern void abort(void); - - abort(); -} diff --git a/qt/qt.h.in b/qt/qt.h.in deleted file mode 100644 index 6e01fec0c..000000000 --- a/qt/qt.h.in +++ /dev/null @@ -1,176 +0,0 @@ -#ifndef QT_H -#define QT_H - -#ifdef __cplusplus -extern "C" { -#endif - -#include <@qtmd_h@> - - -/* A QuickThreads thread is represented by it's current stack pointer. - To restart a thread, you merely need pass the current sp (qt_t*) to - a QuickThreads primitive. `qt_t*' is a location on the stack. To - improve type checking, represent it by a particular struct. */ - -typedef struct qt_t { - char dummy; -} qt_t; - - -/* Alignment is guaranteed to be a power of two. */ -#ifndef QT_STKALIGN - #error "Need to know the machine-dependent stack alignment." -#endif - -#define QT_STKROUNDUP(bytes) \ - (((bytes)+QT_STKALIGN) & ~(QT_STKALIGN-1)) - - -/* Find ``top'' of the stack, space on the stack. */ -#ifndef QT_SP -#ifdef QT_GROW_DOWN -#define QT_SP(sto, size) ((qt_t *)(&((char *)(sto))[(size)])) -#endif -#ifdef QT_GROW_UP -#define QT_SP(sto, size) ((void *)(sto)) -#endif -#if !defined(QT_SP) - #error "QT_H: Stack must grow up or down!" -#endif -#endif - - -/* The type of the user function: - For non-varargs, takes one void* function. - For varargs, takes some number of arguments. */ -typedef void *(qt_userf_t)(void *pu); -typedef void *(qt_vuserf_t)(int arg0, ...); - -/* For non-varargs, just call a client-supplied function, - it does all startup and cleanup, and also calls the user's - function. */ -typedef void (qt_only_t)(void *pu, void *pt, qt_userf_t *userf); - -/* For varargs, call `startup', then call the user's function, - then call `cleanup'. */ -typedef void (qt_startup_t)(void *pt); -typedef void (qt_cleanup_t)(void *pt, void *vuserf_return); - - -/* Internal helper for putting stuff on stack. */ -#ifndef QT_SPUT -#define QT_SPUT(top, at, val) \ - (((qt_word_t *)(top))[(at)] = (qt_word_t)(val)) -#endif - - -/* Push arguments for the non-varargs case. */ -#ifndef QT_ARGS - -#ifndef QT_ARGS_MD -#define QT_ARGS_MD (0) -#endif - -#ifndef QT_STKBASE - #error "Need to know the machine-dependent stack allocation." -#endif - -/* All things are put on the stack relative to the final value of - the stack pointer. */ -#ifdef QT_GROW_DOWN -#define QT_ADJ(sp) (((char *)sp) - QT_STKBASE) -#else -#define QT_ADJ(sp) (((char *)sp) + QT_STKBASE) -#endif - -#define QT_ARGS(sp, pu, pt, userf, only) \ - (QT_ARGS_MD (QT_ADJ(sp)), \ - QT_SPUT (QT_ADJ(sp), QT_ONLY_INDEX, only), \ - QT_SPUT (QT_ADJ(sp), QT_USER_INDEX, userf), \ - QT_SPUT (QT_ADJ(sp), QT_ARGT_INDEX, pt), \ - QT_SPUT (QT_ADJ(sp), QT_ARGU_INDEX, pu), \ - ((qt_t *)QT_ADJ(sp))) - -#endif - - -/* Push arguments for the varargs case. - Has to be a function call because initialization is an expression - and we need to loop to copy nbytes of stuff on to the stack. - But that's probably OK, it's not terribly cheap, anyway. */ - -#ifdef QT_VARGS_DEFAULT -#ifndef QT_VARGS_MD0 -#define QT_VARGS_MD0(sp, vasize) (sp) -#endif -#ifndef QT_VARGS_MD1 -#define QT_VARGS_MD1(sp) do { ; } while (0) -#endif - -#ifndef QT_VSTKBASE - #error "Need base stack size for varargs functions." -#endif - -/* Sometimes the stack pointer needs to munged a bit when storing - the list of arguments. */ -#ifndef QT_VARGS_ADJUST -#define QT_VARGS_ADJUST(sp) (sp) -#endif - -/* All things are put on the stack relative to the final value of - the stack pointer. */ -#ifdef QT_GROW_DOWN -#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE) -#else -#define QT_VADJ(sp) (((char *)sp) + QT_VSTKBASE) -#endif - -extern qt_t *qt_vargs (qt_t *sp, int nbytes, void *vargs, - void *pt, qt_startup_t *startup, - qt_vuserf_t *vuserf, qt_cleanup_t *cleanup); - -#ifndef QT_VARGS -#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \ - (qt_vargs (sp, nbytes, vargs, pt, startup, vuserf, cleanup)) -#endif - -#endif - - -/* Save the state of the thread and call the helper function - using the stack of the new thread. */ -typedef void *(qt_helper_t)(qt_t *old, void *a0, void *a1); -typedef void *(qt_block_t)(qt_helper_t *helper, void *a0, void *a1, - qt_t *newthread); - -/* Rearrange the parameters so that things passed to the helper - function are already in the right argument registers. */ -#ifndef QT_ABORT -extern qt_abort (qt_helper_t *h, void *a0, void *a1, qt_t *newthread); -/* The following does, technically, `return' a value, but the - user had better not rely on it, since the function never - returns. */ -#define QT_ABORT(h, a0, a1, newthread) \ - do { qt_abort (h, a0, a1, newthread); } while (0) -#endif - -#ifndef QT_BLOCK -extern void *qt_block (qt_helper_t *h, void *a0, void *a1, - qt_t *newthread); -#define QT_BLOCK(h, a0, a1, newthread) \ - (qt_block (h, a0, a1, newthread)) -#endif - -#ifndef QT_BLOCKI -extern void *qt_blocki (qt_helper_t *h, void *a0, void *a1, - qt_t *newthread); -#define QT_BLOCKI(h, a0, a1, newthread) \ - (qt_blocki (h, a0, a1, newthread)) -#endif - -#ifdef __cplusplus -} /* Match `extern "C" {' at top. */ -#endif - -#endif /* ndef QT_H */ diff --git a/qt/stp.c b/qt/stp.c deleted file mode 100644 index bfacc893b..000000000 --- a/qt/stp.c +++ /dev/null @@ -1,199 +0,0 @@ -#include "copyright.h" -#include "qt.h" -#include "stp.h" - -#ifndef NULL -#define NULL 0 -#endif - -#define STP_STKSIZE (0x1000) - -/* `alignment' must be a power of 2. */ -#define STP_STKALIGN(sp, alignment) \ - ((void *)((((qt_word_t)(sp)) + (alignment) - 1) & ~((alignment)-1))) - - -/* The notion of a thread is merged with the notion of a queue. - Thread stuff: thread status (sp) and stuff to use during - (re)initialization. Queue stuff: next thread in the queue - (next). */ - -struct stp_t { - qt_t *sp; /* QuickThreads handle. */ - void *sto; /* `malloc'-allocated stack. */ - struct stp_t *next; /* Next thread in the queue. */ -}; - - -/* A queue is a circular list of threads. The queue head is a - designated list element. If this is a uniprocessor-only - implementation we can store the `main' thread in this, but in a - multiprocessor there are several `heavy' threads but only one run - queue. A fancier implementation might have private run queues, - which would lead to a simpler (trivial) implementation */ - -typedef struct stp_q_t { - stp_t t; - stp_t *tail; -} stp_q_t; - - -/* Helper functions. */ - -extern void *malloc (unsigned size); -extern void perror (char const *msg); -extern void free (void *sto); - - void * -xmalloc (unsigned size) -{ - void *sto; - - sto = malloc (size); - if (!sto) { - perror ("malloc"); - exit (1); - } - return (sto); -} - -/* Queue access functions. */ - - static void -stp_qinit (stp_q_t *q) -{ - q->t.next = q->tail = &q->t; -} - - - static stp_t * -stp_qget (stp_q_t *q) -{ - stp_t *t; - - t = q->t.next; - q->t.next = t->next; - if (t->next == &q->t) { - if (t == &q->t) { /* If it was already empty .. */ - return (NULL); /* .. say so. */ - } - q->tail = &q->t; /* Else now it is empty. */ - } - return (t); -} - - - static void -stp_qput (stp_q_t *q, stp_t *t) -{ - q->tail->next = t; - t->next = &q->t; - q->tail = t; -} - - -/* Thread routines. */ - -static stp_q_t stp_global_runq; /* A queue of runable threads. */ -static stp_t stp_global_main; /* Thread for the process. */ -static stp_t *stp_global_curr; /* Currently-executing thread. */ - -static void *stp_starthelp (qt_t *old, void *ignore0, void *ignore1); -static void stp_only (void *pu, void *pt, qt_userf_t *f); -static void *stp_aborthelp (qt_t *sp, void *old, void *null); -static void *stp_yieldhelp (qt_t *sp, void *old, void *blockq); - - - void -stp_init() -{ - stp_qinit (&stp_global_runq); -} - - - void -stp_start() -{ - stp_t *next; - - while ((next = stp_qget (&stp_global_runq)) != NULL) { - stp_global_curr = next; - QT_BLOCK (stp_starthelp, 0, 0, next->sp); - } -} - - - static void * -stp_starthelp (qt_t *old, void *ignore0, void *ignore1) -{ - stp_global_main.sp = old; - stp_qput (&stp_global_runq, &stp_global_main); - /* return (garbage); */ -} - - - void -stp_create (stp_userf_t *f, void *pu) -{ - stp_t *t; - void *sto; - - t = xmalloc (sizeof(stp_t)); - t->sto = xmalloc (STP_STKSIZE); - sto = STP_STKALIGN (t->sto, QT_STKALIGN); - t->sp = QT_SP (sto, STP_STKSIZE - QT_STKALIGN); - t->sp = QT_ARGS (t->sp, pu, t, (qt_userf_t *)f, stp_only); - stp_qput (&stp_global_runq, t); -} - - - static void -stp_only (void *pu, void *pt, qt_userf_t *f) -{ - stp_global_curr = (stp_t *)pt; - (*(stp_userf_t *)f)(pu); - stp_abort(); - /* NOTREACHED */ -} - - - void -stp_abort (void) -{ - stp_t *old, *newthread; - - newthread = stp_qget (&stp_global_runq); - old = stp_global_curr; - stp_global_curr = newthread; - QT_ABORT (stp_aborthelp, old, (void *)NULL, newthread->sp); -} - - - static void * -stp_aborthelp (qt_t *sp, void *old, void *null) -{ - free (((stp_t *)old)->sto); - free (old); - /* return (garbage); */ -} - - - void -stp_yield() -{ - stp_t *old, *newthread; - - newthread = stp_qget (&stp_global_runq); - old = stp_global_curr; - stp_global_curr = newthread; - QT_BLOCK (stp_yieldhelp, old, &stp_global_runq, newthread->sp); -} - - - static void * -stp_yieldhelp (qt_t *sp, void *old, void *blockq) -{ - ((stp_t *)old)->sp = sp; - stp_qput ((stp_q_t *)blockq, (stp_t *)old); - /* return (garbage); */ -} diff --git a/qt/stp.h b/qt/stp.h deleted file mode 100644 index 1220e47e2..000000000 --- a/qt/stp.h +++ /dev/null @@ -1,51 +0,0 @@ -#ifndef STP_H -#define STP_H - -/* - * QuickThreads -- Threads-building toolkit. - * Copyright (c) 1993 by David Keppel - * - * Permission to use, copy, modify and distribute this software and - * its documentation for any purpose and without fee is hereby - * granted, provided that the above copyright notice and this notice - * appear in all copies. This software is provided as a - * proof-of-concept and for demonstration purposes; there is no - * representation about the suitability of this software for any - * purpose. - */ - -typedef struct stp_t stp_t; - -/* Each thread starts by calling a user-supplied function of this - type. */ - -typedef void (stp_userf_t)(void *p0); - -/* Call this before any other primitives. */ -extern void stp_init(); - -/* When one or more threads are created by the main thread, - the system goes multithread when this is called. It is done - (no more runable threads) when this returns. */ - -extern void stp_start (void); - -/* Create a thread and make it runable. When the thread starts - running it will call `f' with arguments `p0' and `p1'. */ - -extern void stp_create (stp_userf_t *f, void *p0); - -/* The current thread stops running but stays runable. - It is an error to call `stp_yield' before `stp_start' - is called or after `stp_start' returns. */ - -extern void stp_yield (void); - -/* Like `stp_yield' but the thread is discarded. Any intermediate - state is lost. The thread can also terminate by simply - returning. */ - -extern void stp_abort (void); - - -#endif /* ndef STP_H */ diff --git a/qt/time/.cvsignore b/qt/time/.cvsignore deleted file mode 100644 index f3c7a7c5d..000000000 --- a/qt/time/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -Makefile diff --git a/qt/time/Makefile.am b/qt/time/Makefile.am deleted file mode 100644 index d56f14496..000000000 --- a/qt/time/Makefile.am +++ /dev/null @@ -1,5 +0,0 @@ -## Process this file with automake to produce Makefile.in. - -AUTOMAKE_OPTIONS = foreign - -EXTRA_DIST = README.time assim cswap go init prim raw diff --git a/qt/time/Makefile.in b/qt/time/Makefile.in deleted file mode 100644 index 895269857..000000000 --- a/qt/time/Makefile.in +++ /dev/null @@ -1,148 +0,0 @@ -# Makefile.in generated automatically by automake 1.1l from Makefile.am - -# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc. -# This Makefile.in is free software; the Free Software Foundation -# gives unlimited permission to copy, distribute and modify it. - - -SHELL = /bin/sh - -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -VPATH = @srcdir@ -prefix = @prefix@ -exec_prefix = @exec_prefix@ - -bindir = @bindir@ -sbindir = @sbindir@ -libexecdir = @libexecdir@ -datadir = @datadir@ -sysconfdir = @sysconfdir@ -sharedstatedir = @sharedstatedir@ -localstatedir = @localstatedir@ -libdir = @libdir@ -infodir = @infodir@ -mandir = @mandir@ -includedir = @includedir@ -oldincludedir = /usr/include - -pkgdatadir = $(datadir)/@PACKAGE@ -pkglibdir = $(libdir)/@PACKAGE@ -pkgincludedir = $(includedir)/@PACKAGE@ - -top_builddir = .. - -INSTALL = @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -transform = @program_transform_name@ -host_alias = @host_alias@ -host_triplet = @host@ -RANLIB = @RANLIB@ -module = @module@ -qtmd_h = @qtmd_h@ -CC = @CC@ -PACKAGE = @PACKAGE@ -VERSION = @VERSION@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ -qtmds_o = @qtmds_o@ -qtmdc_o = @qtmdc_o@ -target_libs = @target_libs@ -qtmds_s = @qtmds_s@ -qtmdc_c = @qtmdc_c@ -qtmdb_s = @qtmdb_s@ - -AUTOMAKE_OPTIONS = foreign - -EXTRA_DIST = README.time assim cswap go init prim raw -mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs -CONFIG_CLEAN_FILES = -DIST_COMMON = Makefile.am Makefile.in - - -DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \ - $(TEXINFOS) $(MANS) $(EXTRA_DIST) - -TAR = tar -default: all - -.SUFFIXES: -$(srcdir)/Makefile.in: Makefile.am $(top_srcdir)/configure.in $(ACLOCAL) - cd $(top_srcdir) && automake --foreign time/Makefile - -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES) - cd $(top_builddir) \ - && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= $(SHELL) ./config.status - -tags: TAGS -TAGS: - - -distdir = $(top_builddir)/$(PACKAGE)-$(VERSION)/$(subdir) - -subdir = time -distdir: $(DISTFILES) - @for file in $(DISTFILES); do \ - d=$(srcdir); \ - test -f $(distdir)/$$file \ - || ln $$d/$$file $(distdir)/$$file 2> /dev/null \ - || cp -p $$d/$$file $(distdir)/$$file; \ - done -info: -dvi: -check: all - $(MAKE) -installcheck: -install-exec: - $(NORMAL_INSTALL) - -install-data: - $(NORMAL_INSTALL) - -install: install-exec install-data all - @: - -uninstall: - -all: Makefile - -install-strip: - $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install -installdirs: - - -mostlyclean-generic: - test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES) - -clean-generic: - test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) - -distclean-generic: - rm -f Makefile $(DISTCLEANFILES) - rm -f config.cache config.log stamp-h - test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) - -maintainer-clean-generic: - test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES) - test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES) -mostlyclean: mostlyclean-generic - -clean: clean-generic mostlyclean - -distclean: distclean-generic clean - rm -f config.status - -maintainer-clean: maintainer-clean-generic distclean - @echo "This command is intended for maintainers to use;" - @echo "it deletes files that may require special tools to rebuild." - -.PHONY: default tags distdir info dvi installcheck install-exec \ -install-data install uninstall all installdirs mostlyclean-generic \ -distclean-generic clean-generic maintainer-clean-generic clean \ -mostlyclean distclean maintainer-clean - - -# Tell versions [3.59,3.63) of GNU make to not export all variables. -# Otherwise a system limit (for SysV at least) may be exceeded. -.NOEXPORT: diff --git a/qt/time/README.time b/qt/time/README.time deleted file mode 100644 index 4bb190e18..000000000 --- a/qt/time/README.time +++ /dev/null @@ -1,17 +0,0 @@ -The program `raw', when run in `..' runs the program `run' produced -from `meas.c'. It produces a raw output file (see `../tmp/*.raw'). -`raw' will die with an error if run in the current directory. Note -that some versions of `time' produce output in an unexpected format; -edit them by hand. - -`prim', `init', `cswap' and `go' produce formatted table entries used -in the documentation (in `../doc'). For example, from `..', - - foreach i (tmp/*.raw) - time/prim $i - end - -See notes in the QuickThreads document about the applicability of -these microbenchmark measurements -- in general, you can expect all -QuickThreads operations to be a bit slower when used in a real -application. diff --git a/qt/time/assim b/qt/time/assim deleted file mode 100755 index 6c4c52183..000000000 --- a/qt/time/assim +++ /dev/null @@ -1,42 +0,0 @@ -#! /bin/awk -f - -BEGIN { - nmach = 0; - - init_test = "1"; - abort_test = "6"; - blocki_test = "7"; - block_test = "8"; -} - -{ - mach = $1 - test = $2 - iter = $3 - time = $6 + $8 - - if (machi[mach] == 0) { - machn[nmach] = mach; - machi[mach] = 1; - ++nmach; - } - - us_per_op = time / iter * 1000000 - times[mach "_" test] = us_per_op; -} - - -END { - for (i=0; i<nmach; ++i) { - m = machn[i]; - init = times[m "_" init_test]; - printf ("init %s | %f\n", m, init); - - init_abort_blocki = times[m "_" abort_test]; - abort_blocki = init_abort_blocki - init; - blocki = times[m "_" blocki_test]; - abort = abort_blocki - blocki; - blockf = times[m "_" block_test]; - printf ("swap %s | %f | %f | %f\n", m, abort, blocki, blockf); - } -} diff --git a/qt/time/cswap b/qt/time/cswap deleted file mode 100755 index 0ec811bcd..000000000 --- a/qt/time/cswap +++ /dev/null @@ -1,37 +0,0 @@ -#! /bin/awk -f - -BEGIN { - purpose = "report time used by int only and int+fp cswaps"; - - nmach = 0; - - test_int = "7"; - test_fp = "8"; -} - -{ - mach = $1 - test = $2 - iter = $3 - time = $6 + $8 - - if (machi[mach] == 0) { - machn[nmach] = mach; - machi[mach] = 1; - ++nmach; - } - - us_per_op = time / iter * 1000000 - times[mach "_" test] = us_per_op; -} - - -END { - for (i=0; i<nmach; ++i) { - m = machn[i]; - - integer = times[m "_" test_int]; - fp = times[m "_" test_fp]; - printf ("%s|%3.1f|%3.1f\n", m, integer, fp); - } -} diff --git a/qt/time/go b/qt/time/go deleted file mode 100755 index 489d53882..000000000 --- a/qt/time/go +++ /dev/null @@ -1,43 +0,0 @@ -#! /bin/awk -f - -BEGIN { - purpose = "report times used for init/start/stop"; - - nmach = 0; - - test_single = "6"; - test_v0 = "10"; - test_v2 = "11"; - test_v4 = "12"; - test_v8 = "13"; -} - -{ - mach = $1 - test = $2 - iter = $3 - time = $6 + $8 - - if (machi[mach] == 0) { - machn[nmach] = mach; - machi[mach] = 1; - ++nmach; - } - - us_per_op = time / iter * 1000000 - times[mach "_" test] = us_per_op; -} - - -END { - for (i=0; i<nmach; ++i) { - m = machn[i]; - - single = times[m "_" test_single]; - v0 = times[m "_" test_v0]; - v2 = times[m "_" test_v2]; - v4 = times[m "_" test_v4]; - v8 = times[m "_" test_v8]; - printf ("%s|%3.1f|%3.1f|%3.1f|%3.1f|%3.1f\n", m, single, v0, v2, v4, v8); - } -} diff --git a/qt/time/init b/qt/time/init deleted file mode 100755 index 8bcbf3428..000000000 --- a/qt/time/init +++ /dev/null @@ -1,42 +0,0 @@ -#! /bin/awk -f - -BEGIN { - purpose = "Report time used to initialize a thread." - nmach = 0; - - test_single = "1"; - test_v0 = "14"; - test_v2 = "15"; - test_v4 = "16"; - test_v8 = "17"; -} - -{ - mach = $1 - test = $2 - iter = $3 - time = $6 + $8 - - if (machi[mach] == 0) { - machn[nmach] = mach; - machi[mach] = 1; - ++nmach; - } - - us_per_op = time / iter * 1000000 - times[mach "_" test] = us_per_op; -} - - -END { - for (i=0; i<nmach; ++i) { - m = machn[i]; - - single = times[m "_" test_single]; - v0 = times[m "_" test_v0]; - v2 = times[m "_" test_v2]; - v4 = times[m "_" test_v4]; - v8 = times[m "_" test_v8]; - printf ("%s|%3.1f|%3.1f|%3.1f|%3.1f|%3.1f\n", m, single, v0, v2, v4, v8); - } -} diff --git a/qt/time/prim b/qt/time/prim deleted file mode 100755 index 22b323f6f..000000000 --- a/qt/time/prim +++ /dev/null @@ -1,41 +0,0 @@ -#! /bin/awk -f - -BEGIN { - purpose = "report times for microbenchmarks" - - nmach = 0; - - test_callind = "18"; - test_callimm = "18"; - test_addreg = "20"; - test_loadreg = "21"; -} - -{ - mach = $1 - test = $2 - iter = $3 - time = $6 + $8 - - if (machi[mach] == 0) { - machn[nmach] = mach; - machi[mach] = 1; - ++nmach; - } - - ns_per_op = time / iter * 1000000 - times[mach "_" test] = ns_per_op; -} - - -END { - for (i=0; i<nmach; ++i) { - m = machn[i]; - - ind = times[m "_" test_callind]; - imm = times[m "_" test_callimm]; - add = times[m "_" test_addreg]; - load = times[m "_" test_loadreg]; - printf ("%s|%1.3f|%1.3f|%1.3f|%1.3f\n", m, ind, imm, add, load); - } -} diff --git a/qt/time/raw b/qt/time/raw deleted file mode 100755 index 96ae10ad1..000000000 --- a/qt/time/raw +++ /dev/null @@ -1,58 +0,0 @@ -#! /bin/csh - -rm -f timed - -set init=1 -set runone=6 -set blockint=7 -set blockfloat=8 -set vainit0=14 -set vainit2=15 -set vainit4=16 -set vainit8=17 -set vastart0=10 -set vastart2=11 -set vastart4=12 -set vastart8=13 -set bench_regcall=18 -set bench_immcall=19 -set bench_add=20 -set bench_load=21 - -source configuration - -echo -n $config_machine $init $config_init -/bin/time run $init $config_init -echo -n $config_machine $runone $config_runone -/bin/time run $runone $config_runone -echo -n $config_machine $blockint $config_blockint -/bin/time run $blockint $config_blockint -echo -n $config_machine $blockfloat $config_blockfloat -/bin/time run $blockfloat $config_blockfloat - -echo -n $config_machine $vainit0 $config_vainit0 -/bin/time run $vainit0 $config_vainit0 -echo -n $config_machine $vainit2 $config_vainit2 -/bin/time run $vainit2 $config_vainit2 -echo -n $config_machine $vainit4 $config_vainit4 -/bin/time run $vainit4 $config_vainit4 -echo -n $config_machine $vainit8 $config_vainit8 -/bin/time run $vainit8 $config_vainit8 - -echo -n $config_machine $vastart0 $config_vastart0 -/bin/time run $vastart0 $config_vastart0 -echo -n $config_machine $vastart2 $config_vastart2 -/bin/time run $vastart2 $config_vastart2 -echo -n $config_machine $vastart4 $config_vastart4 -/bin/time run $vastart4 $config_vastart4 -echo -n $config_machine $vastart8 $config_vastart8 -/bin/time run $vastart8 $config_vastart8 - -echo -n $config_machine $bench_regcall $config_bcall_reg -/bin/time run $bench_regcall $config_bcall_reg -echo -n $config_machine $bench_immcall $config_bcall_imm -/bin/time run $bench_immcall $config_bcall_imm -echo -n $config_machine $bench_add $config_b_add -/bin/time run $bench_add $config_b_add -echo -n $config_machine $bench_load $config_b_load -/bin/time run $bench_load $config_b_load diff --git a/threads.m4 b/threads.m4 deleted file mode 100644 index 0466e8c7b..000000000 --- a/threads.m4 +++ /dev/null @@ -1,102 +0,0 @@ -dnl -dnl CY_AC_WITH_THREADS determines which thread library the user intends -dnl to put underneath guile. Pass it the path to find the guile top-level -dnl source directory. Eg CY_AC_WITH_THREADS(../..) for tcl/unix. -dnl - -AC_DEFUN([CY_AC_WITH_THREADS],[ -AC_CACHE_CHECK("threads package type",cy_cv_threads_package,[ -AC_CACHE_VAL(cy_cv_threads_cflags,[ -AC_CACHE_VAL(cy_cv_threads_libs,[ -use_threads=no; -AC_ARG_WITH(threads,[ --with-threads thread interface], - use_threads=$withval, use_threads=no) -test -n "$use_threads" || use_threads=qt -threads_package=unknown -if test "$use_threads" != no; then -dnl -dnl Test for the qt threads package - used for cooperative threads -dnl This may not necessarily be built yet - so just check for the -dnl header files. -dnl - if test "$use_threads" = yes || test "$use_threads" = qt; then - # Look for qt in source directory. This is a hack: we look in - # "./qt" because this check might be run at the top level. - if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then - threads_package=COOP - cy_cv_threads_cflags="-I$srcdir/../qt -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - else - if test -f $use_threads/qt.c; then - # FIXME seems as though we should try to use an installed qt here. - threads_package=COOP - cy_cv_threads_cflags="-I$use_threads -I../qt" - cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a" - fi - fi - if test "$use_threads" = pthreads; then - # Look for pthreads in srcdir. See above to understand why - # we always set threads_package. - if test -f $srcdir/../../pthreads/pthreads/queue.c \ - || test -f $srcdir/../pthreads/pthreads/queue.c; then - threads_package=MIT - cy_cv_threads_cflags="-I$srcdir/../../pthreads/include" - cy_cv_threads_libs="-L../../pthreads/lib -lpthread" - fi - fi - saved_CPP="$CPPFLAGS" - saved_LD="$LDFLAGS" - saved_LIBS="$LIBS" - if test "$threads_package" = unknown; then -dnl -dnl Test for the FSU threads package -dnl - CPPFLAGS="-I$use_threads/include" - LDFLAGS="-L$use_threads/lib" - LIBS="-lgthreads -lmalloc" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=FSU) - fi - if test "$threads_package" = unknown; then -dnl -dnl Test for the MIT threads package -dnl - LIBS="-lpthread" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=MIT) - fi - if test "$threads_package" = unknown; then -dnl -dnl Test for the PCthreads package -dnl - LIBS="-lpthreads" - AC_TRY_LINK([#include <pthread.h>],[ -pthread_equal(NULL,NULL); -], threads_package=PCthreads) - fi -dnl -dnl Set the appropriate flags! -dnl - cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags" - cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs" - cy_cv_threads_package=$threads_package - CPPFLAGS="$saved_CPP" - LDFLAGS="$saved_LD" - LIBS="$saved_LIBS" - if test "$threads_package" = unknown; then - AC_MSG_ERROR("cannot find thread library installation") - fi -fi -]) -]) -], -dnl -dnl Set flags according to what is cached. -dnl -CPPFLAGS="$cy_cv_threads_cflags" -LIBS="$cy_cv_threads_libs" -) -]) |