diff options
| author | Jim Blandy <jimb@red-bean.com> | 1996-07-25 22:56:11 +0000 |
|---|---|---|
| committer | Jim Blandy <jimb@red-bean.com> | 1996-07-25 22:56:11 +0000 |
| commit | 0f2d19dd46f83f41177f61d585732b32a866d613 (patch) | |
| tree | 86bf67b8c05d36d8181d393e7d706785a74ee777 | |
| download | guile-jimb.tar.gz | |
maintainer changed: was lord, now jimb; first importjimb
155 files changed, 53863 insertions, 0 deletions
diff --git a/COPYING b/COPYING new file mode 100644 index 000000000..9648fb9ea --- /dev/null +++ b/COPYING @@ -0,0 +1,339 @@ + 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/GUILE-VERSION b/GUILE-VERSION new file mode 100644 index 000000000..891b63016 --- /dev/null +++ b/GUILE-VERSION @@ -0,0 +1,4 @@ +GUILE_MAJOR_VERSION=1 +GUILE_MINOR_VERSION=0 +GUILE_VERSION=$GUILE_MAJOR_VERSION.$GUILE_MINOR_VERSION + diff --git a/Makefile.in b/Makefile.in new file mode 100644 index 000000000..c2334e3f7 --- /dev/null +++ b/Makefile.in @@ -0,0 +1,294 @@ +# Copyright (C) 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, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + + +SHELL = /bin/sh + +subdirs=@existingdirs@ + +localfiles = ANNOUNCE \ + COPYING \ + Makefile.in \ + configure \ + configure.in \ + config.sub \ + config.guess \ + install-sh + +localtreats = ANN.BX + +# `all' +# Compile the entire program. This should be the default target. +# This target need not rebuild any documentation files; info files +# should normally be included in the distribution, and DVI files +# should be made only when explicitly asked for. +all: + @for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} all; \ + cd .. ;\ + done + +#`install' +# Compile the program and copy the executables, libraries, and so on +# to the file names where they should reside for actual use. If +# there is a simple test to verify that a program is properly +# installed then run that test. +# +# Use `-' before any command for installing a man page, so that +# `make' will ignore any errors. This is in case there are systems +# that don't have the Unix man page documentation system installed. +# +# In the future, when we have a standard way of installing info +# files, `install' targets will be the proper place to do so. +# +subdir-inst-target=install-nobuild + +install: all + ${MAKE} subdir-inst-target=install install-nobuild + +install-nobuild: + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} ${subdir-inst-target}; \ + cd .. ;\ + done + +#`uninstall' +# Delete all the installed files that the `install' target would +# create (but not the noninstalled files such as `make all' would +# create). +uninstall: + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} uninstall; \ + cd .. ;\ + done + + +#`clean' +# Delete all files from the current directory that are normally +# created by building the program. Don't delete the files that +# record the configuration. Also preserve files that could be made +# by building, but normally aren't because the distribution comes +# with them. +# +# Delete `.dvi' files here if they are not part of the distribution. +# +clean: + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} clean; \ + cd .. ;\ + done + +#`distclean' +# Delete all files from the current directory that are created by +# configuring or building the program. If you have unpacked the +# source and built the program without creating any other files, +# `make distclean' should leave only the files that were in the +# distribution. +distclean: + rm -f config.cache + rm -f config.log + rm -f config.status + rm -f Makefile + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} distclean; \ + cd .. ;\ + done + + +#`mostlyclean' +# Like `clean', but may refrain from deleting a few files that people +# normally don't want to recompile. For example, the `mostlyclean' +# target for GCC does not delete `libgcc.a', because recompiling it +# is rarely necessary and takes a lot of time. +mostlyclean: + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} mostlyclean; \ + cd .. ;\ + done + + +#`realclean' +# Delete everything from the current directory that can be +# reconstructed with this Makefile. This typically includes +# everything deleted by distclean, plus more: C source files +# produced by Bison, tags tables, info files, and so on. +# +# One exception, however: `make realclean' should not delete +# `configure' even if `configure' can be remade using a rule in the +# Makefile. More generally, `make realclean' should not delete +# anything that needs to exist in order to run `configure' and then +# begin to build the program. +realclean: + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} realclean; \ + cd .. ;\ + done + + +#`TAGS' +# Update a tags table for this program. +TAGS: + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} TAGS; \ + cd .. ;\ + done + +#`info' +# Generate any info files needed. The best way to write the rules +# is as follows: +# +# info: foo.info +# +# foo.info: $(srcdir)/foo.texi $(srcdir)/chap1.texi $(srcdir)/chap2.texi +# $(MAKEINFO) $(srcdir)/foo.texi +# +# You must define the variable `MAKEINFO' in the Makefile. It +# should run the Makeinfo program, which is part of the Texinfo2 +# distribution. +info: + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} info; \ + cd .. ;\ + done + + +#`dvi' +# Generate DVI files for all TeXinfo documentation. For example: +# +# dvi: foo.dvi +# +# foo.dvi: $(srcdir)/foo.texi $(srcdir)/chap1.texi $(srcdir)/chap2.texi +# $(TEXI2DVI) $(srcdir)/foo.texi +# +# You must define the variable `TEXI2DVI' in the Makefile. It should +# run the program `texi2dvi', which is part of the Texinfo2 +# distribution. Alternatively, write just the dependencies, and +# allow GNU Make to provide the command. +dvi: + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} dvi; \ + cd .. ;\ + done + +#`dist' +# Create a distribution tar file for this program. The tar file +# should be set up so that the file names in the tar file start with +# a subdirectory name which is the name of the package it is a +# distribution for. This name can include the version number. +# +# For example, the distribution tar file of GCC version 1.40 unpacks +# into a subdirectory named `gcc-1.40'. +# +# The easiest way to do this is to create a subdirectory +# appropriately named, use `ln' or `cp' to install the proper files +# in it, and then `tar' that subdirectory. +# +# The `dist' target should explicitly depend on all non-source files +# that are in the distribution, to make sure they are up to date in +# the distribution. *Ref Making Releases: (standards)Releases. +distname = brand-x +distdir = $(distname) +treats = $(localtreats) +announcefile = ANN.BX + +manifest-file: + rm -f MANIFEST + cp $(announcefile) ANNOUNCE + for treat in $(localfiles) $(treats) ; \ + do echo $$treat >> MANIFEST ; \ + done + for subdir in $(subdirs) ; do \ + make -s -f $$subdir/Makefile.in SUBDIR=$$subdir manifest >> MANIFEST ; \ + done + sed -e "s%^%$(distdir)/%" MANIFEST > M2 + sed -e "/Entering dir/d" -e "/Leaving dir/d" M2 > MANIFEST + rm M2 + + + +dist: manifest-file + mkdir $(distdir) + - cd $(distdir); \ + for file in $(localfiles) $(treats) $(subdirs); do ln -s ../$$file .; done; \ + cd ..; \ + gtar -zhcvf $(distname).tar.gz --files-from MANIFEST + rm -rf $(distdir) + -gtar ztvf $(distname).tar.gz | grep ".*~" > BACKUPS + test -s BACKUPS && (echo WARNING -- MANIFEST INCLUDES BACK FILES; cat BACKUPS) + +#`check' +# Perform self-tests (if any). The user must build the program +# before running the tests, but need not install the program; you +# should write the self-tests so that they work when the program is +# built but not installed. +check: + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} check; \ + cd .. ;\ + done + + +#`installcheck' +# Perform installation tests (if any). The user must build and +# install the program before running the tests. You should not +# assume that `$(bindir)' is in the search path. +installcheck: + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} installcheck; \ + cd .. ;\ + done + + +#`installdirs' +# It's useful to add a target named `installdirs' to create the +# directories where files are installed, and their parent +# directories. There is a script called `mkinstalldirs' which is +# convenient for this; find it in the Texinfo package.You can use a +# rule like this: +# +# # Make sure all installation directories, e.g. $(bindir) actually exist by +# # making them if necessary. +# installdirs: mkinstalldirs +# $(srcdir)/mkinstalldirs $(bindir) $(datadir) $(libdir) \ +# $(infodir) $(mandir) +installdirs: + for dir in ${subdirs}; do \ + cd $$dir; \ + ${MAKE} installdirs; \ + cd .. ;\ + done + + + +# Cygnus extention: +# +# `Makefile' +# Calls `./config.status' to rebuild the `Makefile' in this +# directory. +Makefile: + ${SHELL-/bin/sh} config.status diff --git a/config.guess b/config.guess new file mode 100755 index 000000000..a3d6a9f1b --- /dev/null +++ b/config.guess @@ -0,0 +1,497 @@ +#! /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 new file mode 100755 index 000000000..5641cc1ce --- /dev/null +++ b/config.sub @@ -0,0 +1,833 @@ +#! /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 new file mode 100755 index 000000000..098617faf --- /dev/null +++ b/configure @@ -0,0 +1,868 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.9 +# 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= + +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.9" + 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 LANG and LC_ALL to C if already set. +# These must not be set unconditionally because not all systems understand +# e.g. LANG=C (notably SCO). +if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +if test "${LANG+set}" = set; then LANG=C; export LANG; 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' + +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 + + + +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_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. + +subdirs="$all_subdirs" + +existingdirs= +for d in $all_subdirs; do + if test -d $srcdir/$d ; then + existingdirs="$existingdirs $d" + if test "x$verbose" = xyes; then + if test -f $srcdir/$d/PLUGIN/greet ; then + cat $srcdir/$d/PLUGIN/greet + else + echo === + echo === Configuring plug-in component $d + echo === + fi + fi + fi +done + +for d in $req_subdirs; do + if test ! -d $srcdir/$d ; then + echo "*******" + echo "*******" + echo "**\+/**" + echo "**=*=**" ERROR: Missing required package: $d + echo "**/+\**" + echo "*******" + echo "*******" + exit 1 + fi +done + +if test "x$verbose" = xyes; then + for d in $opt_subdirs; do + if test ! -d $srcdir/$d ; then + echo "*****" + echo "*===*" + echo "*=*=*" WARNING: Missing suggested package: $d + echo "*===*" + echo "*****" + fi + done +fi + + + +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 +# 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 | + sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \ + >> 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.9" + 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 + +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%@subdirs@%$subdirs%g +s%@existingdirs@%$existingdirs%g + +CEOF +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]", 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 relative srcdir, etc. 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 + + 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 + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file +fi; done +rm -f conftest.subs + + + +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 + + 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=../$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. + # A "../" for each directory in /$ac_config_dir. + ac_dots=`echo $ac_config_dir|sed -e 's%^\./%%' -e 's%[^/]$%&/%' -e 's%[^/]*/%../%g'` + case "$cache_file" in + /*) ac_sub_cache_file=$cache_file ;; + *) # Relative path. + ac_sub_cache_file="$ac_dots$cache_file" ;; + 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 new file mode 100644 index 000000000..6ea5ef4c6 --- /dev/null +++ b/configure.in @@ -0,0 +1,50 @@ +AC_INIT(Makefile.in) + +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) +existingdirs= +for d in $all_subdirs; do + if test -d $srcdir/$d ; then + existingdirs="$existingdirs $d" + if test "x$verbose" = xyes; then + if test -f $srcdir/$d/PLUGIN/greet ; then + cat $srcdir/$d/PLUGIN/greet + else + echo === + echo === Configuring plug-in component $d + echo === + fi + fi + fi +done + +for d in $req_subdirs; do + if test ! -d $srcdir/$d ; then + echo "*******" + echo "*******" + echo "**\+/**" + echo "**=*=**" ERROR: Missing required package: $d + echo "**/+\**" + echo "*******" + echo "*******" + exit 1 + fi +done + +if test "x$verbose" = xyes; then + for d in $opt_subdirs; do + if test ! -d $srcdir/$d ; then + echo "*****" + echo "*===*" + echo "*=*=*" WARNING: Missing suggested package: $d + echo "*===*" + echo "*****" + fi + done +fi + + +AC_SUBST(existingdirs) +AC_OUTPUT(Makefile) diff --git a/ice-9/COPYING b/ice-9/COPYING new file mode 100644 index 000000000..9648fb9ea --- /dev/null +++ b/ice-9/COPYING @@ -0,0 +1,339 @@ + 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 new file mode 100644 index 000000000..fe69f1e0b --- /dev/null +++ b/ice-9/ChangeLog @@ -0,0 +1,5 @@ +Fri Apr 19 13:53:08 1996 Tom Lord <lord@beehive> + + * The more things change... + + diff --git a/ice-9/Makefile.in b/ice-9/Makefile.in new file mode 100644 index 000000000..318dc4a56 --- /dev/null +++ b/ice-9/Makefile.in @@ -0,0 +1,71 @@ +# 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. +# + + + +SHELL = /bin/sh + +srcdir = @srcdir@ +VPATH = @srcdir@ +prefix = @prefix@ + +VERSION=@GUILE_VERSION@ + +libparent=$(prefix)/lib +libdir=$(libparent)/guile$(VERSION) +install_path=$(libdir)/@library_name@ + +INSTALL = $(srcdir)/../install-sh -c +INSTALL_DATA = $(INSTALL) -m 644 + +scm_files= @scm_files@ +aux_files = @aux_files@ + +all: + +install: all + test -d $(libparent) || mkdir $(libparent) + test -d $(libdir) || mkdir $(libdir) + test -d $(install_path) || mkdir $(install_path) + cd $(srcdir); \ + for file in $(scm_files); do \ + $(INSTALL_DATA) $$file $(install_path); \ + done + +uninstall: + for file in $(scm_files) ; do \ + rm -f $(install_path)/$$file; \ + done; + -rmdir $(install_path) + -rmdir $(libdir) + + +SUBDIR=. +manifest: + srcdir=./$(SUBDIR) ; \ + . $(SUBDIR)/PLUGIN/this.configure; \ + for file in $$scm_files $$aux_files ; \ + do echo $(SUBDIR)/$$file ; \ + done + +clean: + +distclean: + -rm -f config.log config.status Makefile + +realclean: + diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm new file mode 100644 index 000000000..fa55e9a1d --- /dev/null +++ b/ice-9/boot-9.scm @@ -0,0 +1,3663 @@ +;;; 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. +;;; + + + +;; {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 ") + (print 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)) + + + +;;; {apply-to-args} +;;; +;;; 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)) + + +;;; {Silly Naming Cleanups and Trivial Functions} +;;; + +(define %open-file open-file) +(define (id x) x) +(define < <?) +(define <= <=?) +(define = =?) +(define > >?) +(define >= >=?) +(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 '())) + +;;; {Integer Math} +;;; + +(define (integer? x) (and (number? x) (= x (inexact->exact x)))) + +(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)))) + + +;;; {Basic Port Code} +;;; +;;; Specificly, 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 +;;; is 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 (open-input-file str) + (or (open-file str OPEN_READ) + (error "OPEN-INPUT-FILE couldn't find file " str))) + +(define (open-output-file str) + (or (open-file str OPEN_WRITE) + (error "OPEN-OUTPUT-FILE couldn't find file " str))) + +(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)))) + + + +;;; {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} +;;; + +(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-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 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 + (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 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))) + + +;;; {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 (file-exists? str) + (let ((port (open-file str OPEN_READ))) + (if port (begin (close-port port) #t) + #f))) + +(define (file-is-directory? str) + (let ((port (open-file (string-append str "/.") OPEN_READ))) + (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} +;;; + + +;; (error . args) is short for (throw (quote error) . args) +;; +(define (error . args) + (apply throw 'error args)) + + + + +;; Error handling a la SCM. +;; +(define (%%default-error-handler tag . args) + (define cep (current-error-port)) + (perror "ERROR") + (errno 0) + (display "ERROR: " cep) + (if (not (null? args)) + (begin (display (car args) cep) + (for-each (lambda (x) (display #\ cep) (write x cep)) + (cdr args)))) + (newline cep) + (force-output cep) + (apply throw 'abort tag args)) + + + +;; Install SCM error handling as the default. +;; +(set-symbol-property! 'error + 'throw-handler-default + %%default-error-handler) + + + + + +;; %%bad-throw is the hook that is called upon a throw to a an unhandled +;; key. 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)) + (throw 'error 'unhandled-exception key args)))) + + + + + +;; A number of internally defined error types are 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) + (cond + ((= n 21) (unmask-signals) (timer-thunk)) + ((= n 20) (unmask-signals) (gc-thunk)) + ((= n 19) (unmask-signals) (alarm-thunk)) + (else (unmask-signals) (throw '%%system-error n #f)))) + + +;; The default handler for built-in error types when +;; thrown by their symbolic name. The action is to +;; convert the error into a generic error, building +;; a descriptive message for the error. +;; +(define (%%handle-system-error ignored desc proc . args) + (let* ((b (assoc desc %%system-errors)) + (msghead (cond + (b (caddr b)) + ((or (symbol? desc) (string? desc)) + (string-append desc " ")) + (#t "Unknown error"))) + (msg (if (symbol? proc) + (string-append msghead proc ":") + msghead)) + (rest (if (and proc (not (symbol? proc))) + (cons proc args) + args)) + (fixed-args (cons msg rest))) + (apply error fixed-args))) + + +(set-symbol-property! '%%system-error + 'throw-handler-default + %%handle-system-error) + + +;; Install default handlers for built-in errors. +;; +(map (lambda (err) + (set-symbol-property! (cadr err) + 'throw-handler-default + %%handle-system-error)) + (cdr %%system-errors)) + + + + +(define ((make-simple-wrapper func) . args) + (or (apply func args) + (apply throw 'syserror func (errno) args))) + +(define ((make-eof-wrapper func) . args) + (let ((rv (apply func args))) + (if (eof-object? rv) + (apply throw 'syserror func (errno) args) + rv))) + +(define ((make-errno-wrapper func) . args) + (let ((rv (apply func args))) + (if (number? rv) + (apply throw 'syserror func rv args) + rv))) + +(define ((make-errpair-wrapper func) . args) + (let ((rv (apply func args))) + (if (and (pair? rv) + (number? (car rv)) + (null? (cdr rv))) + (apply throw 'syserror func (car rv) args) + rv))) + +(begin + (define (syserror key fn err . args) + (errno err) + (apply error (cons fn args))) + (set-symbol-property! 'syserror 'throw-handler-default syserror)) + + +(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) + (if (= 1 (primitive-move->fdes port fd)) + (set-port-revealed! port 1) + #t)) + +(define accept (make-errno-wrapper %accept)) +(define bind (make-errno-wrapper %bind)) +(define chdir (make-errno-wrapper %chdir)) +(define chmod (make-errno-wrapper %chmod)) +(define chown (make-errno-wrapper %chown)) +(define close (make-errno-wrapper %close)) +(define closedir (make-errno-wrapper %closedir)) +(define connect (make-errno-wrapper %connect)) +(define copy-file (make-simple-wrapper %copy-file)) +(define ctermid (make-simple-wrapper %ctermid)) +(define delete-file (make-errno-wrapper %delete-file)) +(define duplicate-port (make-simple-wrapper %duplicate-port)) +(define execl (make-errno-wrapper %execl)) +(define execlp (make-errno-wrapper %execlp)) +(define fdopen (make-errno-wrapper %fdopen)) +(define fileno (make-simple-wrapper %fileno)) +(define fork (make-simple-wrapper %fork)) +(define freopen (make-errno-wrapper %freopen)) +(define fseek (make-errno-wrapper %fseek)) +(define ftell (make-errno-wrapper %ftell)) +(define getcwd (make-errno-wrapper %getcwd)) +(define getenv (make-simple-wrapper %getenv)) +(define getgrgid (make-errno-wrapper %getgrgid)) +(define getgrnam (make-errno-wrapper %getgrnam)) +(define getgroups (make-errno-wrapper %getgroups)) +(define gethostbyaddr (make-simple-wrapper %gethostbyaddr)) +(define gethost (make-simple-wrapper %gethost)) +(define gethostbyname (make-simple-wrapper %gethostbyname)) +(define getnetbyaddr (make-simple-wrapper %getnetbyaddr)) +(define getnetbyname (make-simple-wrapper %getnetbyname)) +(define getpeername (make-errno-wrapper %getpeername)) +(define getprotobyname (make-simple-wrapper %getprotobyname)) +(define getprotobynumber (make-simple-wrapper %getprotobynumber)) +(define getpwnam (make-simple-wrapper %getpwnam)) +(define getpwuid (make-simple-wrapper %getpwuid)) +(define getservbyname (make-simple-wrapper %getservbyname)) +(define getservbyport (make-simple-wrapper %getservbyport)) +(define getsockname (make-errno-wrapper %getsockname)) +(define getsockopt (make-errpair-wrapper %getsockopt)) +(define inet-aton (make-simple-wrapper %inet-aton)) +(define isatty? (make-errno-wrapper %isatty?)) +(define kill (make-errno-wrapper %kill)) +(define link (make-errno-wrapper %link)) +(define listen (make-errno-wrapper %listen)) +(define lstat (make-errno-wrapper %lstat)) +(define mkdir (make-errno-wrapper %mkdir)) +(define mknod (make-errno-wrapper %mknod)) +(define nice (make-errno-wrapper %nice)) +(define opendir (make-errno-wrapper %opendir)) +(define pipe (make-errno-wrapper %pipe)) +(define primitive-move->fdes (make-simple-wrapper %primitive-move->fdes)) +(define putenv (make-errno-wrapper %putenv)) +(define read-fd (make-errpair-wrapper %read-fd)) +(define readdir (make-errno-wrapper %readdir)) +(define readlink (make-errno-wrapper %readlink)) +(define recv (make-errno-wrapper %recv)) +(define recvfrom (make-errno-wrapper %recvfrom)) +(define redirect-port (make-errno-wrapper %redirect-port)) +(define rename-file (make-errno-wrapper %rename-file)) +(define rmdir (make-errno-wrapper %rmdir)) +(define select (make-errno-wrapper %select)) +(define send (make-errpair-wrapper %send)) +(define sendto (make-errpair-wrapper %sendto)) +(define setegid (make-errno-wrapper %setegid)) +(define seteuid (make-errno-wrapper %seteuid)) +(define setgid (make-errno-wrapper %setgid)) +(define setlocale (make-errno-wrapper %setlocale)) +(define setpgid (make-errno-wrapper %setpgid)) +(define setsid (make-simple-wrapper %setsid)) +(define setsockopt (make-errno-wrapper %setsockopt)) +(define setuid (make-errno-wrapper %setuid)) +(define shutdown (make-errno-wrapper %shutdown)) +(define socket (make-errno-wrapper %socket)) +(define socketpair (make-errno-wrapper %socketpair)) +(define stat (make-errno-wrapper %stat)) +(define strptime (make-simple-wrapper %strptime)) +(define symlink (make-simple-wrapper %symlink)) +(define tcgetpgrp (make-simple-wrapper %tcgetpgrp)) +(define tcsetpgrp (make-simple-wrapper %tcsetpgrp)) +(define ttyname (make-errno-wrapper %ttyname)) +(define uname (make-errno-wrapper %uname)) +(define utime (make-errno-wrapper %utime)) +(define waitpid (make-errno-wrapper %waitpid)) +(define write-fd (make-errpair-wrapper %write-fd)) +(define move->fdes (make-simple-wrapper %move->fdes)) + + +;;; {Load Paths} +;;; + +(define implementation-vicinity compiled-library-path) + +;;; Here for backward compatability +;; +(define scheme-file-suffix (lambda () ".scm")) + +(define in-vicinity string-append) + +(define (parse-path env_path) + (cond ((string? env_path) + (let loop ((curdir "") (env env_path) (path '())) + (cond ((= (string-length env) 0) + (if (> (string-length curdir) 0) + (append path (list curdir)) + path)) + ((char=? (string-ref env 0) #\:) + (loop "" + (substring env 1 (string-length env)) + (append path (list curdir)))) + (#t + (loop (string-append curdir (substring env 0 1)) + (substring env 1 (string-length env)) + path))))) + (#t '()))) + +(define %load-path (append (parse-path (%getenv "SCHEME_LOAD_PATH")) + (list "" + (in-vicinity (implementation-vicinity) "gls/guile/") + (in-vicinity (implementation-vicinity) "gls/") + (in-vicinity (implementation-vicinity) "slib/")))) + +;;; {try-load} +;;; + +(define (try-load-with-path file-name path) + (or-map (lambda (d) + (let ((f (in-vicinity d file-name))) + (and (not (file-is-directory? f)) + (%try-load f #t read-sharp)))) + path)) + +(define (try-load name) + (if (eval '(defined? %load-path)) + (try-load-with-path name (eval '%load-path)) + (%try-load name #t read-sharp))) + +;;; {Load} +;;; + +(define %load-verbosely #t) +(define (assert-load-verbosity v) (set! %load-verbosely v)) +(define %load-indent -2) + +(define (%load f) + (current-module) + (or (and (not (file-is-directory? f)) + (%try-load f #t read-sharp)) + (and (not (has-suffix? f (scheme-file-suffix))) + (%try-load (string-append f (scheme-file-suffix)) #t read-sharp)))) + +(define (%load-announce file) + (if %load-verbosely + (with-output-to-port (current-error-port) + (lambda () + (display ";;; ") + (display (make-string %load-indent #\ )) + (display "loading ") + (display file) + (display "...") + (newline) + (force-output))))) + +(define (%load-announce-win file) + (if %load-verbosely + (with-output-to-port (current-error-port) + (lambda () + (display ";;; ") + (display (make-string %load-indent #\ )) + (display "...loaded ") + (display file) + (display ".") + (newline) + (force-output))))) + +(define (%load-announce-lossage file path) + (if %load-verbosely + (with-output-to-port (current-error-port) + (lambda () + (display ";;; ") + (display (make-string %load-indent #\ )) + (display "...COULD NOT LOAD ") + (display file) + (display " from ") + (write path) + (newline) + (force-output)))) + (throw 'could-not-load file path)) + + +(define (load-with-path name path) + (define (do-load) + (%load-announce name) + (if (not (or-map (lambda (d) + (if (%load (in-vicinity d name)) + (begin + (%load-announce-win (in-vicinity d name)) + #t) + #f)) + path)) + (%load-announce-lossage name path))) + + (let ((indent %load-indent)) + (dynamic-wind + (lambda () (set! %load-indent (modulo (+ indent 2) 16))) + do-load + (lambda () (set! %load-indent indent)))) + #t) + + +(define (load name) + (if (eval '(defined? %load-path)) + (load-with-path name (eval '%load-path)) + (load-with-path name '()))) + + + +;;; {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 (seperate-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)))))) + (seperate-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)) + ((#\!) (if (= 1 (line-number)) + (let skip () (if (eq? #\newline (peek-char port)) + (read port #t read-sharp) + (begin (read-char port) (skip)))) + (barf))) + (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...> +;;; +;;; + + +;; 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 (THUNK 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-thunk name kind) %print-module)) + +;; make-module &opt size uses +;; +;; Create a new module, perhaps with a particular size of obarray +;; or initial uses list. +;; +(define module-constructor (record-constructor module-type)) + +(define make-module + (lambda args + (let* ((size 1021) + (uses '()) + (binder #f) + (answer #f) + (eval-thunk + (lambda (symbol define?) + (if define? + (module-make-local-var! answer symbol) + (module-variable answer symbol))))) + + (if (> (length args) 0) + (begin + (set! size (or (car args) size)) + (set! args (cdr args)))) + + (if (> (length args) 0) + (begin + (set! uses (or (car args) uses)) + (set! args (cdr args)))) + + (if (> (length args) 0) + (begin + (set! binder (or (car args) binder)) + (set! args (cdr args)))) + + (if (not (null? args)) + (error "Too many args to make-module." args)) + + (if (not (integer? size)) + (error "Illegal size to make-module." size)) + + (and (list? uses) + (or (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)) + + (set! answer + (module-constructor (make-vector size '()) + uses + binder + eval-thunk + #f + #f)) + answer))) + +(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-thunk (record-accessor module-type 'eval-thunk)) +(define set-module-eval-thunk! (record-modifier module-type 'eval-thunk)) +(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-thunk 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-thunk 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 #f root-module-thunk)) + + +;; 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 #f + (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-thunk* (module-eval-thunk the-module)) + (set! *top-level-lookup-thunk* #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-try-load-with-path try-load-with-path) +(define basic-try-load try-load) +(define basic-load-with-path load-with-path) +(define basic-load load) + + +(define (try-load-module-with-path . args) + (save-module-excursion (lambda () (apply basic-try-load-with-path args)))) + +(define (try-load-module . args) + (save-module-excursion (lambda () (apply basic-try-load args)))) + +(define (load-module-with-path . args) + (save-module-excursion (lambda () (apply basic-load-with-path args)))) + +(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. +;;; +;;; (resolved-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 +;;; +;;; resolved-ref a-root name +;;; resolved-set! a-root name val +;;; resolved-define! a-root name val +;;; resolved-remove! a-root name +;;; +;;; +;;; (current-module) is a natural choice for a-root so for convenience there are +;;; also: +;;; +;;; value-ref name == resolved-ref (current-module) name +;;; value-set! name val == resolved-set! (current-module) name val +;;; value-define! name val == resolved-define! (current-module) name val +;;; value-remove! name == resolved-remove! (current-module) name +;;; + + +(define (resolved-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 (resolved-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 (resolved-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 (resolved-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 (value-ref names) (resolved-ref (current-module) names)) +(define (value-set! names val) (resolved-set! (current-module) names val)) +(define (value-define names val) (resolved-define! (current-module) names val)) +(define (value-remove names) (resolved-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)) +(value-define '(app modules) (make-module 31)) +(value-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 (value-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)) + + +(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 (not (file-is-directory? full)) + (file-exists? full) + (begin + (save-module-excursion + (lambda () + (list f d) + (load-with-path f (list d)))) + #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-hash-table 523)) +(define xformer-table (make-weak-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) (eval `(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) (eval `(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 scm-repl-verbose #t) +(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 () + (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 (key . args) + (case key + ((quit) (force-output) + (pk 'quit args) + #f) + + ((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)))) + + (else ;; This is the other cons-leak closure... + (lambda () + (apply %%bad-throw key args)))))))) + (and next (loop next)))) + (loop (lambda () #t))) + +(define (quit . args) + (apply throw 'quit args)) + +(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 (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))) + (let ((val (read (current-input-port) #t read-sharp))) + (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) + (eval sourc))) + + (-print (lambda (result) + (if (not scm-repl-silent) + (begin + (print 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))) + + + + + +(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 try-load-with-path try-load-module-with-path) +(define try-load try-load-module) +(define load-with-path load-module-with-path) +(define load load-module) + + + + +;; (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)) + + +(define-module (ice-9 calling)) + +;;;; +;;; {Calling Conventions} +;;; +;;; 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))) + + + + +(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))))) + + +(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 (resolved-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 (resolved-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-value-define name value) + (let ((parent (reverse! (cdr (reverse name))))) + (and parent (make-modules-in (current-module) parent)) + (value-define name value))) + +(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))) + + + + +;;; installed-scm-file +(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. +;;;; + + + +;;;; +;;; {The runq data structure} +;;; +;;; 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)) + + + +;;; installed-scm-file + +(define-module (ice-9 string-fun)) + + +;;;; +;;; {String Fun} +;;; +;;; Various string funcitons, particularly those that take +;;; advantage of the "shared substring" capability. +;;; + +;;;; +;;; {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 (seperate-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 (seperate-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 (seperate-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 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=?)) + + +;;;; +;;; {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))) + +;;;; +;;; {has-trailing-newline?} +;;; + +(define-public (has-trailing-newline? str) + (and (< 0 (string-length str)) + (char=? #\nl (string-ref str (1- (string-length str)))))) + + + + + +(define-public (with-regexp-parts regexp fields str return fail) + (let ((parts (regexec regexp str fields))) + (if (number? parts) + (fail parts) + (apply return parts)))) + + + +(define-module (guile)) + diff --git a/ice-9/configure b/ice-9/configure new file mode 100755 index 000000000..25b98d1a0 --- /dev/null +++ b/ice-9/configure @@ -0,0 +1,722 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.9 +# 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= + +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.9" + 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 LANG and LC_ALL to C if already set. +# These must not be set unconditionally because not all systems understand +# e.g. LANG=C (notably SCO). +if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +if test "${LANG+set}" = set; then LANG=C; export LANG; 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' + +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 + +scm_files="" +aux_files="" +. $srcdir/PLUGIN/this.configure + + + + + +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 +# 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 | + sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \ + >> 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.9" + 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 + +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%@scm_files@%$scm_files%g +s%@aux_files@%$aux_files%g +s%@library_name@%$library_name%g +s%@info_files@%$info_files%g +s%@GUILE_VERSION@%$GUILE_VERSION%g + +CEOF +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]", 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 relative srcdir, etc. 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 + + 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 + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file +fi; done +rm -f conftest.subs + + + +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 new file mode 100644 index 000000000..cb1926a87 --- /dev/null +++ b/ice-9/configure.in @@ -0,0 +1,17 @@ +# +# Process this file with autoconf to produce a configure script. +# + +AC_INIT(boot-9.scm) + +. $srcdir/../GUILE-VERSION + +scm_files="" +aux_files="" +. $srcdir/PLUGIN/this.configure +AC_SUBST(scm_files) +AC_SUBST(aux_files) +AC_SUBST(library_name) +AC_SUBST(info_files) +AC_SUBST(GUILE_VERSION) +AC_OUTPUT(Makefile) diff --git a/ice-9/hcons.scm b/ice-9/hcons.scm new file mode 100644 index 000000000..febd5e8c7 --- /dev/null +++ b/ice-9/hcons.scm @@ -0,0 +1,76 @@ +;;; 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 new file mode 100644 index 000000000..ffde88608 --- /dev/null +++ b/ice-9/lineio.scm @@ -0,0 +1,112 @@ +;;; 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 new file mode 100644 index 000000000..9d9bb7aa6 --- /dev/null +++ b/ice-9/mapping.scm @@ -0,0 +1,120 @@ +;;; 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) make-vector))) + (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 new file mode 100644 index 000000000..b594ebe13 --- /dev/null +++ b/ice-9/poe.scm @@ -0,0 +1,117 @@ +;;; 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-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/slib.scm b/ice-9/slib.scm new file mode 100644 index 000000000..3178598fd --- /dev/null +++ b/ice-9/slib.scm @@ -0,0 +1,144 @@ +;;; 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) + (load name)))) + +(define slib:load-source slib:load) +(define defmacro:load slib:load) + +(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 "require.scm") + +(define-public require require:require) diff --git a/ice-9/tags.scm b/ice-9/tags.scm new file mode 100644 index 000000000..58b7425b4 --- /dev/null +++ b/ice-9/tags.scm @@ -0,0 +1,23 @@ +;;; 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/install-sh b/install-sh new file mode 100755 index 000000000..ab74c882e --- /dev/null +++ b/install-sh @@ -0,0 +1,238 @@ +#!/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/COPYING b/libguile/COPYING new file mode 100644 index 000000000..9648fb9ea --- /dev/null +++ b/libguile/COPYING @@ -0,0 +1,339 @@ + 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 b/libguile/ChangeLog new file mode 100644 index 000000000..1726e3cb5 --- /dev/null +++ b/libguile/ChangeLog @@ -0,0 +1,521 @@ +Wed Jun 12 00:28:31 1996 Tom Lord <lord@beehive> + + * struct.c (scm_init_struct): new file. + +Fri Jun 7 14:02:00 1996 Tom Lord <lord@beehive> + + * list.c (scm_list_tail): list-cdr-ref is the same as list-tail. + (scm_list_head): added list-head for rapidly chopping argument + lists off of longer lists (and similar). + +Tue Jun 4 09:40:33 1996 Tom Lord <lord@beehive> + + * objprop.c (scm_object_property): assq the cdr of the whash + handle for obj, not the handle itself. + +Mon Jun 3 17:19:30 1996 Tom Lord <lord@beehive> + + * gc.c (scm_mark_weak_vector_spines): Mark the spines (alists) of + weak hash tables last of all marking to avoid an obscure gc bug. + WARNING: circular lists stored in a weak hash table will hose us. + +Fri May 24 09:53:39 1996 Tom Lord <lord@beehive> + + * vectors.c (scm_vector_move_left_x, scm_vector_move_right_x): + new functions similar to scm_substring_move_left_x and + scm_substring_move_right_x. + +Wed May 22 20:07:01 1996 Tom Lord <lord@beehive> + + * init.c (scm_boot_guile): prevent gc with scm_block_gc not + scm_gc_heap_lock! + +Wed May 15 16:13:29 1996 Tom Lord <lord@beehive> + + * ports.c (scm_unread_char): scm_gen_ungetc as a scheme procedure. + +Thu May 9 09:33:17 1996 Tom Lord <lord@beehive> + + * strports.c (scm_strprint_obj): convenience function. C for + (lambda (obj) (call-with-output-string (lambda (p) (write obj p)))) + + * guile-{tcl,tk}.[ch], events.[ch], keysyms.[ch], tcl-channels.[ch] + removed to a separate library + + * init.c (scm_boot_guile): copied from guile-tcl.c. + Initialization specific to tcl interpreters removed. + +Wed May 8 15:07:37 1996 Tom Lord <lord@beehive> + + * ports.c (scm_ports_prehistory): size malloced here doesn't + matter so long as it is non-0 (got rid of "* 4"). + +Tue May 7 11:43:37 1996 Tom Lord <lord@beehive> + + * gscm.h: gscm_mkarray eliminated (presumably was not being used + since its definition was bogus). + +Mon May 6 13:02:56 1996 Tom Lord <lord@beehive> + + * mallocs.[ch]: back again (for rx at least). + +Wed Apr 17 08:54:20 1996 Tom Lord <lord@beehive> + + * ports.c: removed functions relating to the mapping between ports + and descriptors. (That stuff is unix-specific and should be collected + in a separate library). + + * ramap.c (scm_array_copy): return #<unspecified> not #<undefined>. + (Tom Mckay@avanticorp.com) + +Mon Apr 15 14:16:55 1996 Tom Lord <lord@beehive> + + * gc.c (scm_gc_sweep): Immediates in weak vectors were not + handled correctly (SCM_FREEP was applied to them) -- test for + NIMP. Keys in weak hash tables were spuriously (though harmlessly) + being overwritten with #f. (brown@grettir.bibliotech.com) + +Tue Apr 2 22:25:00 1996 Tom Lord <lord@beehive> + + * gc.c (scm_unhash_name): new procedure, unhash-name, flushes glocs + for a specific symbol or for all symbols. + +Mon Apr 1 10:34:55 1996 Tom Lord <lord@beehive> + + * gc.c (scm_gc_mark): mark weak hash tables correctly (was getting weak + keys and weak values confused). + +Thu Mar 14 22:20:20 1996 Tom Lord <lord@beehive> + + * list.c (scm_last_pair): map '()=>'() + +Wed Mar 13 16:43:34 1996 Tom Lord <lord@beehive> + + * pairs.c, hashtab.c, list.c, alist.c append.c, sequences.c: + Generalized assoc and hash-table functions. + Factored pairs.c into multiple files. + +Fri Mar 8 14:44:39 1996 Tom Lord <lord@beehive> + + * gscm.c (gscm_run_scm): got rid of objprop. + +Fri Mar 1 10:39:52 1996 Tom Lord <lord@beehive> + + * genio.c (scm_getc): + NOTE: fgetc may not be interruptable. + + * procprop.c (scm_stand_in_scm_proc): + NOTE: don't use a alist here. + (scm_set_procedure_properties_x): fix type checking throughout this file. + + * gc.c (scm_gc_sweep): free heap segments with free, not must_free. + + * ports.c (scm_remove_from_port_table): adjust scm_mallocated + after freeing part of the port table. + +Thu Feb 29 16:21:17 1996 Tom Lord <lord@beehive> + + * strports.c (scm_mkstrport): + * vports.c (scm_make_soft_port): allocate a port table entry + (possibly triggering gc) before setting the tag of the corresponding + ports handle. + + * pairs.c (scm_delq_x): never throw an error. + + * vectors.c (scm_make_vector): made the default vector fill argument + into '() (much more useful than the previous value, "#unspecified") + +Mon Feb 26 17:19:09 1996 Tom Lord <lord@beehive> + + * ports.c (scm_add_to_port_table): Added fields + to port table entries: file_name, line_num, col. + Update these in open_file, gen_getc and gen_ungetc. + Added procedures to access those fields. + +Sun Feb 25 00:10:36 1996 Tom Lord <lord@beehive> + + * procs.c (scm_make_subr_opt): new entry point for making + anonymous subrs. + +Sat Feb 24 17:11:31 1996 Tom Lord <lord@beehive> + + * gc.h: SCM_STACK_GROWS_UP is now set by autoconf. + +Fri Feb 23 10:26:29 1996 Tom Lord <lord@beehive> + + * numbers.c (scm_exact_p): This function no longer + implements "integer?". + +Thu Feb 22 20:56:16 1996 Tom Lord <lord@beehive> + + * gc.c (scm_gc_end): simulate a signal at the end of each GC. + (scm_gc_stats): return an assoc of useful data. Replaces "room" + and the stats reporting formerlly built into repl. + + * repl.[ch]: removed. + GC statistics keeping moved to gc.c. + Other statistics keeping can be done from Scheme. + REPLS are now written in Scheme. + +Wed Feb 21 10:28:53 1996 Tom Lord <lord@beehive> + + * cnsvobj.c (gscm_is_gscm_obj): new file for old functions (icky + conservatively marked objects). + + * throw.c (scm_ithrow): Unwind up to the right catch during a throw! + + * error.c (scm_init_error): init system_error_sym here, not in repl.c. + + * feature.c (scm_compiled_library_path): moved here from repl.c. + This file is for stuff relating specifically to Scheme libraries + like slib. + + * eval.c (scm_m_define): don't give warning about redefinition, don't + check verbosity. + + NOTE: this should throw a resumable exception with parameters -- + the name, the top-level env, the variable, the definition, #t/#f: redefining builtin? + + * repl.c (scm_gc_begin/end): don't print a message, don't check verbosity. + + * error.c: scm_warn eliminated. + + * read.c (scm_lreadr): extra right paren gets an error, not a warning. + + * repl.c, marksweep.c, gc.c (various): + lose exit_report, growth_mon. + + * gscm.c: got rid of verbosity functions. + +Tue Feb 20 00:19:10 1996 Tom Lord <lord@beehive> + + * throw.c (scm_ithrow): guard against the bad-throw hook changing + between the call to procedurep and use. + + * error.c (scm_everr): + * gc.c (fixconfig): + * gsubr.c (scm_make_gsubr): use exit, not scm_quit. still wrong, + but less so. + + * strports.c: don't reveal the port's string to the caller + because it changes size. + + (stputc stwrite): check/change the strings length with interrupts + blocked. + + * objprop.c (scm_set_object_property_x &c): use the generic + hashing functions and be threadsafe. + + * eval.c (scm_unmemocar): do this operation in a thread-safe way. + (per suggestion jaffer@gnu.ai.mit.edu). + + * mbstrings.c (scm_multi_byte_string): guard against argument list + changing length. + + * strings.c (scm_make_string): loop cleanup + + * unif.c (scm_vector_set_length_x): scm_vector_set_length_x no longer + a scheme function. + + * weaks.c (scm_weak_vector): guard against argument list + changing length. + + * variable.c (scm_builtin_variable): check for/make a built-in + variable automicly. + + * vectors.c (scm_vector): while filling the new array, + guard against a list of fill elements that grows after + the vector is allocated. + + * hashtab.c -- new file: general hash table + functions. hash, hashq, hashv, hashx. + + * tags.h: made wvect an option bit of vector. + +Mon Feb 19 09:38:05 1996 Tom Lord <lord@beehive> + + * symbols.c: made the basic symbol table operations atomic. + + * root.c &c.: collected stack-specific global state. + linum/colnum etc *should* be port-specific state. + + * struct.c (scm_init_struct): init the first struct type during + initialization to fix a race condition. + + * continuations.c (scm_dynthrow): pass throwval in the 'regs' + object, not in a global. + (suggested by green@cygnus, jaffer@gnu.ai.mit.edu) + + * throw.c (_scm_throw): Pass throwval on the stack, not in a global + (suggested by green@cygnus, jaffer@gnu.ai.mit.edu) + + * *.[ch]: namespace cleanup. Changed all (nearly) exported CPP + and C symbols to begin with SCM_ or scm_. + +Sun Feb 18 15:55:38 1996 Tom Lord <lord@beehive> + + * gsubr.c (scm_gsubr_apply): statically allocate the + array of arguments (bothner@cygnus.com). + +Sat Feb 17 20:20:40 1996 Tom Lord <lord@beehive> + + * scmsigs.c: Simplified to use async rountines. + + * async.c: New support for interrupt handlers. + +Thu Feb 15 11:39:09 1996 Tom Lord <lord@beehive> + + * symbols.c (scm_string_to_symbol et al.): number of tweaky changes to + set the multi_byte flag correctly in symbols. This is wrong. + intern_obbary_soft and msymbolize should take an extra parameter. + Also, weird multibyte symbols don't print correctly. + The weird symbol syntax is also a bit bogus (emacs doesn't quite + cope). + +Tue Feb 13 11:39:37 1996 Tom Lord <lord@beehive> + + * symbols.c (scm_string_to_obarray_symbol): obarray == #f means + use the system symhash. == #t means create an uninterned symbol. + +Wed Feb 7 09:28:02 1996 Tom Lord <lord@beehive> + + * strings.c (scm_make_shared_substring): build'em. + It might better to keep a table of these and use one + less cons-pair per shared-substring. + +Tue Feb 6 17:45:21 1996 Tom Lord <lord@beehive> + + * strings.c (scm_string_shared_substring): create shared + substrings. (Doesn't handle mb strings yet). + + * mbstrings.c (scm_print_mb_string): handle RO strings. + + * print.c (scm_iprin1): print substrings as their non-substring + counterparts (dubious). + + * marksweep.c (scm_gc_mark scm_gc_sweep): handle RO and MB + strings. + + * hash.c (scm_hasher): hash RO and MB strings as bytestrings. + + * eval.c (SCM_CEVAL): self-evaluate RO and MB strings. + + * eq.c (scm_equal_p): handle RO and MB strings. + + * symbols.c (scm_string_to_symbol): + (scm_string_to_obarray_symbol): + * strop.c (scm_i_index): + (scm_i_rindex): + (scm_string_null_p): + (scm_string_to_list): + * strings.c (scm_string_length): + (scm_string_ref): + (scm_substring): + (scm_string_append): + * simpos.c (scm_system): + (scm_getenv): + * fports.c (scm_open_file): + * strorder.c (scm_string_equal_p): + (scm_string_ci_equal_p): + (scm_string_less_p): + (scm_string_ci_less_p): + * pairs.c (scm_obj_length): + * mbstrings.c (scm_multi_byte_string_length): + + Use RO string macros for RO strings. + +Tue Jan 30 09:19:08 1996 Tom Lord <lord@beehive> + + * Makefile.in (CFLAGS ALL_CFLAGS): be more standard. + + * strop.c (scm_i_rindex, scm_i_index): Don't use the BSD functions + index/rindex. Do handle embedded \000 characters. + +Sun Jan 28 13:16:18 1996 Tom Lord <lord@beehive> + + * error.c (def_err_response): (int)scm_err_pos => (long)scm_err_pos + Eliminate a (presumed) warning on some systems. + + * gscm.c (gscm_run_scm): SCM_INIT_PATH => GUILE_INIT_PATH + (Mikael Djurfeldt <mdj@nada.kth.se>) + +Sat Jan 27 12:36:55 1996 Tom Lord <lord@beehive> + + * eval.c (scm_map): added argument type checking. + (kawai@sail.t.u-tokyo.ac.jp) + + * gscm.c (gscm_set_procedure_properties_x): parameter "new" => "new_val" + for C++. (Seth Alves <alves@gryphon.com>) + + (gscm_cstr): uses an uninitialized local variable causing + segv. (kawai@sail.t.u-tokyo.ac.jp) + + + * lvectors.c (scm_get_lvector_hook): + In guile-ii, the lvector code was broken. It was fixed in guile-iii. + It seems to me like if it is broken again in guile-iv...Here is a patch. + "! || (LENGTH (keyvec) == 0))" + (From: Mikael Djurfeldt <mdj@nada.kth.se>) + + + * gscm.c (gscm_sys_default_verbosity): + incorrectly declared for non-__STDC__ + (Tom_Mckay@avanticorp.com) + + * ports.c (scm_setfileno): Tweak the macro a bit + to make it easier to port to systems that use + more than a single structure field to hold a descriptor. + + * debug.c (change_mode): Avoid GNUCism "int foo[n];" + Give a warning, not an error, for unrecognized modes. + + * eval.c (SCM_CEVAL): + static char scm_s_for_each[]; + static char scm_s_map[]; + not needed. + + * strings.c (scm_string_p): + static char s_string[]; + (see next entry) + + * struct.c (scm_sys_struct_set_x): + static char s_sys_make_struct[]; + static char s_sys_struct_ref[]; + static char s_sys_struct_set_x[]; + Rearrange code to eliminate those forward decls for the sake of + broken compilers. + + * variable.c (make_vcell_variable): static char s_make_variable[]; + isn't needed. + + * fports.c (scm_port_mode): + chars modes[3] = ""; + to + chars modes[3]; + modes[0] = '\0'; + (Tom_Mckay@avanticorp.com) + + + * pairs.c (scm_set_cdr_x): non-__STDC__ declaration of + scm_cons2(), scm_acons(), and scm_set_cdr_x() missing semicolon + (Tom_Mckay@avanticorp.com) + + * numbers.c (scm_num_eq_p): Non-__STDC__ declaration of + scm_num_eq_p() was scm_equal_p(). + (Tom_Mckay@avanticorp.com) + + * symbols.c (msymbolize): "CHARS(X) = " => "SETCHARS..." + (Tom_Mckay@avanticorp.com) + +Fri Jan 26 14:03:01 1996 Tom Lord <lord@beehive> + + * weaks.c (scm_make_weak_vector): "VELTS(X) =" => "SETVELTS..." + (Tom_Mckay@avanticorp.com) + + * strop.c (scm_substring_fill_x): + Non-__STDC__ declaration of scm_substring_fill_x() missing semicolon + (Tom_Mckay@avanticorp.com) + + * eval.c (SCM_APPLY): variables "debug_info" -> dbg_info. + Works around a compiler bug on some machines. (Tom_Mckay@avanticorp.com) + + * _scm.h (CxR functions): #define CxR SCM_CxR => #define CxR(X) SCM_CxR(X) + Works around a compiler bug on some machines. (Tom_Mckay@avanticorp.com) + + * lvectors.c (scm_lvector_set_x): avoid VELTS (VELTS (...)[..]) which + can turn into an obscure gc bug. + + * chars.c (scm_char_p): fixed PROC call. + + * gscm.h (gscm_vset): use scm_vector_set_x not (the missing) + scm_vector_set. + +Tue Jan 23 13:29:40 1996 Tom Lord <lord@beehive> + + * elisp.c (new file): dynamic scoping and other bits for + elisp. Don't use this yet unless you specificly want to + hack on elisp emulation. + + * dynwind.c (scm_dowinds): When entering or leaving a dynamic + scope created by scm_with_dynamic_bindings_operation_x, swap + the bindings of that scope with the corresponding globals. + + * continuations.c (scm_make_cont): when a continuation is captured, + relocate the continuation stack chunks registered on the wind chain + to the heap. + +Sun Jan 21 19:31:17 1996 Tom Lord <lord@beehive> + + * eval.c (SCM_CEVAL): if the function position evaluates + to a macro, process it accordingly. (Previously, macros were + handled only if the function position was a symbol naming a + variable bound to a macro). + +Sat Jan 20 23:21:37 1996 Tom Lord <lord@beehive> + + * eval.c (scm_m_set): allow multi-variable set! like + (set! x 1 y 2 z 3). + +Wed Dec 6 02:40:49 1995 Tom Lord <lord@beehive> + + * ports.h fports.c vports.c marksweep.c gc.c strports.c: moved the STREAM + of ports into the port table and replaced it with a port-table + index. + + * repl.c (iprin1): added tc7_mb_string -- same as tc7_string. + + * marksweep.c (scm_gc_mark): added tc7_mb_string -- same as tc7_string. + + * mbstrings.c (new file): functions on multi-byte strings. + + * tags.h (scm_typ7_string, scm_typ7_mb_string): added a tag + for multi-byte strings. Moved the string tag. + + * chars.h chars.c repl.c (many functions): made scm_upcase and scm_downcase + functions that are safe for extended character sets. + + Changed the range of integer->char. + + Changed the tyep of SCM_ICHR. + + + +Tue May 16 17:49:58 1995 Mikael Djurfeldt <mdj@sanscalc.nada.kth.se> + + * guile.c: Changed init file name from "SCM_INIT_PATH" to + "GUILE_INIT_PATH" + +Sun Aug 6 15:14:46 1995 Andrew McCallum <mccallum@vein.cs.rochester.edu> + + * guile.c (gscm_is_gscm_type): New function. (Without this how will we + know that it's safe to pass an object to gscm_get_type?) + (gscm_get_type): Fix tyop in error message. + + * variable.c (scm_variable_ref): fixed assertion test. + (Robert STRANDH <strandh@labri.u-bordeaux.fr>) + + * gscm.h: fixed several prototypes, notably gscm_vref. + Add gscm_is_eq and temporarily commented out gscm_eq (see + the note in gscm.h near gscm_eq if this change effects your + code). + (Reported by Mark Galassi <rosalia@sstcx1.lanl.gov>) + + * pairs.c (scm_obj_length): see next entry. + + * gscm.h (gscm_obj_length): A way to get an integer + length for lists, strings, symbols (treated as strings), + and vectors. Returns -1 on error. + + * eq.c (scm_equal_p): fixed smob case. + (William Gribble <grib@arlut.utexas.edu>) + + * Makefile.in (X_CFLAGS): defined. + (William Gribble <grib@arlut.utexas.edu>) + + * gscm.h (gscm_2_double): provided now + (reported by Mark Galassi <rosalia@sstcx1.lanl.gov>) + +Tue Jun 13 01:04:09 1995 gnu + * Vrooom! + + diff --git a/libguile/Makefile.in b/libguile/Makefile.in new file mode 100644 index 000000000..d1ed25c4f --- /dev/null +++ b/libguile/Makefile.in @@ -0,0 +1,984 @@ +# @configure_input@ + +# 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. +# + + +# +# Makefile for libguile +# + +VPATH = @srcdir@ +srcdir = @srcdir@ +SHELL = /bin/sh + +VERSION=@GUILE_VERSION@ + +# Common prefix for machine-independent installed files. +prefix = @prefix@ + +# Common prefix for machine-dependent installed files. +exec_prefix = @exec_prefix@ + +# Directory in which to install init files &c +libdir = $(exec_prefix)/lib + +# Directory to search by default for included makefiles. +includedir = $(prefix)/include + +# Directory to install `guile' in. +bindir = $(exec_prefix)/bin + + +INSTALL = $(srcdir)/../install-sh -c +INSTALL_DATA = $(INSTALL) -m 644 + +# Programs to make tags files. +ETAGS = etags +CTAGS = ctags -tw + +# where the init files are found +IMPLPATH=$(libdir)/gls/guile + +# where the Tcl and Tk sources are found +TCL_SRC_DIR = @TCL_SRC_DIR@ +TK_SRC_DIR = @TK_SRC_DIR@ + +# CC +X11_INCLUDES = @XINCLUDES@ +XFLAGS = @X_CFLAGS@ +CFLAGS = @CFLAGS@ +INCLUDE_CFLAGS = -I. -I$(srcdir) -I$(TCL_SRC_DIR)/generic -I$(TK_SRC_DIR)/generic +ALL_CFLAGS = $(CFLAGS) $(X_CFLAGS) $(INCLUDE_CFLAGS) $(X11_INCLUDES) -DLIBRARY_PATH=\"$(libdir)/\" @DEFS@ +CC = @CC@ $(ALL_CFLAGS) -Wall + +# CC used as a front end for ld +LDFLAGS = @LDFLAGS@ +CCLD= $(CC) $(LDFLAGS) + +# AR +AR = ar +AR_FLAGS = rc +RANLIB = @RANLIB@ + +# Any extra object files your system needs. +extras = @LIBOBJS@ + +libobjs= alist.o \ + append.o \ + appinit.o \ + arbiters.o \ + async.o \ + boolean.o \ + chars.o \ + continuations.o \ + dynwind.o \ + eq.o \ + error.o \ + eval.o \ + extchrs.o \ + fdsocket.o \ + feature.o \ + files.o \ + filesys.o \ + fports.o \ + gc.o \ + genio.o \ + gsubr.o \ + hash.o \ + hashtab.o \ + init.o \ + ioext.o \ + kw.o \ + list.o \ + load.o \ + mallocs.o \ + markers.o \ + markers.o \ + marksweep.o \ + mbstrings.o \ + numbers.o \ + objprop.o \ + pairs.o \ + ports.o \ + posix.o \ + print.o \ + procprop.o \ + procs.o \ + ramap.o \ + read.o \ + root.o \ + scmsigs.o \ + sequences.o \ + simpos.o \ + smob.o \ + socket.o \ + stackchk.o \ + stime.o \ + strings.o \ + strop.o \ + strorder.o \ + strports.o \ + struct.o \ + symbols.o \ + tag.o \ + throw.o \ + unif.o \ + variable.o \ + vectors.o \ + vports.o \ + weaks.o \ + $(extras) + + +uninstalled_h_files= _scm.h __scm.hd + +installed_h_files= __scm.h \ + alist.h \ + append.h \ + arbiters.h \ + async.h \ + boolean.h \ + chars.h \ + continuations.h \ + dynwind.h \ + eq.h \ + error.h \ + eval.h \ + extchrs.h \ + fdsocket.h \ + feature.h \ + fports.h \ + files.h \ + filesys.h \ + gc.h \ + genio.h \ + gsubr.h \ + hash.h \ + hashtab.h \ + init.h \ + ioext.h \ + kw.h \ + list.h \ + load.h \ + libguile.h \ + mallocs.h \ + markers.h \ + marksweep.h \ + markers.h \ + mbstrings.h \ + numbers.h \ + objprop.h \ + pairs.h \ + ports.h \ + posix.h \ + params.h \ + print.h \ + procs.h \ + procprop.h \ + ramap.h \ + read.h \ + root.h \ + scmsigs.h \ + sequences.h \ + simpos.h \ + smob.h \ + socket.h \ + stackchk.h \ + strports.h \ + struct.h \ + symbols.h \ + tag.h \ + stime.h \ + tags.h \ + variable.h \ + vectors.h \ + vports.h \ + weaks.h \ + unif.h \ + scmhob.h \ + strings.h \ + strop.h \ + strorder.h \ + throw.h \ + unif.h + +h_files=$(uninstalled_h_files) $(installed_h_files) + +c_files= alist.c \ + append.c \ + appinit.c \ + arbiters.c \ + async.c \ + boolean.c \ + chars.c \ + continuations.c \ + dynwind.c \ + eq.c \ + error.c \ + eval.c \ + extchrs.c \ + fdsocket.c \ + feature.c \ + files.c \ + filesys.c \ + fports.c \ + gc.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 \ + markers.c \ + marksweep.c \ + mbstrings.c \ + numbers.c \ + objprop.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 \ + stackchk.c \ + stime.c \ + strings.c \ + strop.c \ + strorder.c \ + strports.c \ + struct.c \ + symbols.c \ + tag.c \ + throw.c \ + unif.c \ + variable.c \ + vectors.c \ + vports.c \ + weaks.c + +gen_c_files= alist.x \ + append.x \ + arbiters.x \ + async.x \ + boolean.x \ + chars.x \ + continuations.x \ + dynwind.x \ + eq.x \ + error.x \ + eval.x \ + extchrs.x \ + fdsocket.x \ + feature.x \ + files.x \ + filesys.x \ + fports.x \ + gc.x \ + genio.x \ + gsubr.x \ + hash.x \ + hashtab.x \ + init.x \ + ioext.x \ + kw.x \ + list.x \ + load.x \ + mallocs.x \ + markers.x \ + marksweep.x \ + mbstrings.x \ + numbers.x \ + objprop.x \ + pairs.x \ + ports.x \ + posix.x \ + print.x \ + procprop.x \ + procs.x \ + ramap.x \ + read.x \ + root.x \ + scmsigs.x \ + sequences.x \ + simpos.x \ + smob.x \ + socket.x \ + stackchk.x \ + stime.x \ + strings.x \ + strop.x \ + strorder.x \ + strports.x \ + struct.x \ + symbols.x \ + tag.x \ + throw.x \ + unif.x \ + variable.x \ + vectors.x \ + vports.x \ + weaks.x + + + +ancillery = gscm.c \ + gscm.h \ + COPYING \ + ChangeLog \ + ChangeLog.scm \ + Makefile.in \ + PLUGIN \ + acconfig-1.5.h \ + configure \ + configure.in \ + def.sed \ + scmconfig.h.in \ + fd.h.in \ + ../doc/guile.texi \ + ../doc/guile.ps \ + ../doc/guile.info \ + ../doc/guile.info-1 \ + ../doc/guile.info-2 \ + ../doc/guile.info-3 \ + ../doc/guile.info-4 \ + ../doc/guile.info-5 \ + ../doc/in.texi \ + ../doc/in.info \ + ../doc/in.ps \ + ../doc/agenda \ + ../doc/texinfo.tex + + +c_sources = $(c_files) $(h_files) +manifest = $(ancillery) $(c_sources) + + +.SUFFIXES: +.SUFFIXES: .o .c .h .ps .dvi .info .texinfo .scm .cd .x .hd + +.cd.c: + ( echo "/* DO NOT EDIT --- AUTO-GENERATED --- DO NOT EDIT */" > $@ \ + && echo -n "#line 1" \" \ + && echo $<\" | sed -e "s,^.*/,," >> $@ \ + && sed -f $(srcdir)/def.sed $< >> $@) \ + || rm -f $@ + +.hd.h: + ( echo "/* DO NOT EDIT --- AUTO-GENERATED --- DO NOT EDIT */" > $@ \ + && echo -n "#line 1" \" >> $@ \ + && echo $<\" | sed -e "s,^.*/,," >> $@ \ + && sed -f $(srcdir)/def.sed $< >> $@) \ + || rm -f $@ + +.c.x: + if test ! -escmconfig.h ; then \ + touch scmconfig.h; \ + fake_scmconfig=1; \ + else \ + fake_scmconfig=0; \ + fi; \ + $(CC) $(ALL_CFLAGS) -I. -DSCM_MAGIC_SNARFER -E $< | grep "^%%%" | sed -e "s/^%%%//" > $@ ; \ + if test $$fake_scmconfig -eq 1 ; then \ + rm scmconfig.h; \ + fi + +.PHONY: all +all: libguile.a + +SUBDIR=. +manifest: + for file in $(manifest) ; \ + do echo $(SUBDIR)/$$file ; \ + done + +libguile.a: $(libobjs) + rm -f libguile.a + $(AR) $(AR_FLAGS) libguile.a $(libobjs) + $(RANLIB) libguile.a + +install: all + test -d $(prefix) || mkdir $(prefix) + test -d $(libdir) || mkdir $(libdir) + test -d $(includedir) || mkdir $(includedir) + test -d $(includedir)/guile$(VERSION) || mkdir $(includedir)/guile$(VERSION) + $(INSTALL_DATA) libguile.a $(libdir)/libguile$(VERSION).a + $(RANLIB) $(libdir)/libguile$(VERSION).a + $(INSTALL_DATA) scmconfig.h $(includedir)/guile$(VERSION) + for h in $(h_files); do \ + $(INSTALL_DATA) $(srcdir)/$$h $(includedir)/guile$(VERSION); \ + done + +uninstall: + -for h in $(h_files); do \ + rm -f $(includedir)/guile$(VERSION)/$$h; \ + done + rm -f $(includedir)/guile$(VERSION)/scmconfig.h + -rmdir $(includedir)/guile$(VERSION) + -rm $(libdir)/libguile$(VERSION).a + + +TAGS: + etags $(c_sources) + + +info: + +clean: + -rm -f libguile.a + -rm -f $(libobjs) + -rm -f $(gen_c_files) + +distclean: clean + -rm -f config.cache + -rm -f config.log + -rm -f config.status + -rm -f Makefile + -rm -f scmconfig.h + + +realclean: distclean + -rm -f $(gen_c_files) + -rm -f scmconfig.h + +xfiles: $(gen_c_files) + +DEPENDS_CFLAGS= + +depends: + touch scmconfig.h + touch $(gen_c_files) + gcc -MM -I. $(DEPENDS_CFLAGS) $(c_files) + rm $(gen_c_files) + rm scmconfig.h + +$(srcdir)/__scm.h: __scm.hd + +### +alist.o : alist.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h alist.x +append.o : append.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h append.x +appinit.o : appinit.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h +arbiters.o : arbiters.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h arbiters.x +async.o : async.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h async.x +boolean.o : boolean.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h boolean.x +chars.o : chars.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h chars.x +continuations.o : continuations.c _scm.h libguile.h __scm.h tags.h smob.h params.h \ + alist.h append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h \ + eq.h error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h \ + fports.h gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h \ + kw.h list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h \ + print.h procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h \ + socket.h stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h \ + tag.h throw.h unif.h variable.h vectors.h vports.h weaks.h continuations.x +dynwind.o : dynwind.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h dynwind.x +eq.o : eq.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h eq.x +error.o : error.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h error.x +eval.o : eval.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h eval.x +extchrs.o : extchrs.c extchrs.h +fdsocket.o : fdsocket.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h fdsocket.x +feature.o : feature.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h feature.x +files.o : files.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h files.x +filesys.o : filesys.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h filesys.x +fports.o : fports.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h fports.x +gc.o : gc.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h gc.x +genio.o : genio.c extchrs.h _scm.h libguile.h __scm.h tags.h smob.h params.h \ + alist.h append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h \ + eq.h error.h pairs.h eval.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h +gsubr.o : gsubr.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h +hash.o : hash.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h hash.x +hashtab.o : hashtab.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h hashtab.x +inet_aton.o : inet_aton.c +init.o : init.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h +ioext.o : ioext.c ioext.x +kw.o : kw.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h kw.x +list.o : list.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h list.x +load.o : load.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h load.x +mallocs.o : mallocs.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h +markers.o : markers.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h +markers.o : markers.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h +marksweep.o : marksweep.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h +mbstrings.o : mbstrings.c extchrs.h _scm.h libguile.h __scm.h tags.h smob.h \ + params.h alist.h append.h arbiters.h async.h boolean.h chars.h continuations.h \ + dynwind.h eq.h error.h pairs.h eval.h fdsocket.h feature.h files.h filesys.h \ + fports.h gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h \ + kw.h list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h \ + print.h procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h \ + socket.h stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h \ + tag.h throw.h unif.h variable.h vectors.h vports.h weaks.h mbstrings.x +numbers.o : numbers.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h numbers.x +objprop.o : objprop.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h objprop.x +pairs.o : pairs.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h pairs.x +ports.o : ports.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h ports.x +posix.o : posix.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h posix.x +print.o : print.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h print.x +procprop.o : procprop.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h procprop.x +procs.o : procs.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h procs.x +ramap.o : ramap.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h ramap.x +read.o : read.c extchrs.h _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h read.x +root.o : root.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h +scmsigs.o : scmsigs.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h scmsigs.x +sequences.o : sequences.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h sequences.x +simpos.o : simpos.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h simpos.x +smob.o : smob.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h +socket.o : socket.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h socket.x +stackchk.o : stackchk.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h stackchk.x +stime.o : stime.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h stime.x +strings.o : strings.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h strings.x +strop.o : strop.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h strop.x +strorder.o : strorder.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h strorder.x +strports.o : strports.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h strports.x +struct.o : struct.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h struct.x +symbols.o : symbols.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h symbols.x +tag.o : tag.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h tag.x +throw.o : throw.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h throw.x +unif.o : unif.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h unif.x +variable.o : variable.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h variable.x +vectors.o : vectors.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h vectors.x +vports.o : vports.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h \ + append.h arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h \ + error.h pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h \ + gc.h marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h \ + list.h load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h \ + procprop.h procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h \ + stackchk.h stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h \ + unif.h variable.h vectors.h vports.h weaks.h vports.x +weaks.o : weaks.c _scm.h libguile.h __scm.h tags.h smob.h params.h alist.h append.h \ + arbiters.h async.h boolean.h chars.h continuations.h dynwind.h eq.h error.h \ + pairs.h eval.h extchrs.h fdsocket.h feature.h files.h filesys.h fports.h gc.h \ + marksweep.h genio.h ports.h gsubr.h hash.h hashtab.h init.h ioext.h kw.h list.h \ + load.h mallocs.h markers.h mbstrings.h symbols.h numbers.h posix.h print.h procprop.h \ + procs.h ramap.h read.h root.h scmsigs.h sequences.h simpos.h socket.h stackchk.h \ + stime.h strings.h strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \ + variable.h vectors.h vports.h weaks.h weaks.x diff --git a/libguile/__scm.h b/libguile/__scm.h new file mode 100644 index 000000000..e3c5772ca --- /dev/null +++ b/libguile/__scm.h @@ -0,0 +1,375 @@ +/* DO NOT EDIT --- AUTO-GENERATED --- DO NOT EDIT */ +#line 1 "__scm.hd" +/* 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. + */ + + +#define CCLO +#define SICP + + + +/* Random options (net yet supported or in final form). */ + +#undef DEBUG_EXTENSIONS +#undef READER_EXTENSIONS +#undef SCM_STACK_LIMIT 20000 +#undef NO_CEVAL_STACK_CHECK +#undef LONGLONGS + +/* Some auto-generated .h files contain unused prototypes + * that need these typedefs. + */ +typedef long long_long; +typedef unsigned long ulong_long; + + + + +/* Define + * + * SCM_CHAR_SCM_CODE_LIMIT == UCHAR_MAX + 1 + * SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2) + * SCM_MOST_NEGATIVE_FIXNUM == SCM_SRS((long)LONG_MIN, 2) + */ + +#ifdef HAVE_LIMITSH +# include <limits.h> +# ifdef UCHAR_MAX +# define SCM_CHAR_SCM_CODE_LIMIT (UCHAR_MAX+1L) +# else +# define SCM_CHAR_SCM_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_SCM_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_LIMITSH */ + + +#include <scmconfig.h> +#include "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 + + +extern unsigned int scm_async_clock; +#define SCM_ASYNC_TICK if (0 == --scm_async_clock) scm_async_click () + +#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_ints_disabled = 1; \ +} \ + + +#define SCM_ALLOW_INTS_ONLY \ +{ \ + scm_ints_disabled = 0; \ +} \ + + +#define SCM_ALLOW_INTS \ +{ \ + SCM_CHECK_NOT_ENABLED; \ + scm_ints_disabled = 0; \ + SCM_ASYNC_TICK; \ +} \ + + +#define SCM_REDEFER_INTS \ +{ \ + ++scm_ints_disabled; \ +} \ + + +#define SCM_REALLOW_INTS \ +{ \ + --scm_ints_disabled; \ + if (!scm_ints_disabled) \ + 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_SCM_OVSCM_FLOW 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) + +struct errdesc +{ + char *msg; + char *s_response; + short parent_err; +}; + + +extern struct errdesc scm_errmsgs[]; + + + +/* 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 */ + + + + +#ifdef __STDC__ + +#else /* STDC */ + +#endif /* STDC */ + + +#endif /* __SCMH */ diff --git a/libguile/__scm.hd b/libguile/__scm.hd new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/libguile/__scm.hd diff --git a/libguile/_scm.h b/libguile/_scm.h new file mode 100644 index 000000000..1c7e74ebc --- /dev/null +++ b/libguile/_scm.h @@ -0,0 +1,130 @@ +/* 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 "libguile.h" + +/* 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 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 +#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 + +#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 /* _SCMH */ + diff --git a/libguile/alist.c b/libguile/alist.c new file mode 100644 index 000000000..85c4395af --- /dev/null +++ b/libguile/alist.c @@ -0,0 +1,455 @@ +/* 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" + + + +SCM_PROC(s_acons, "acons", 3, 0, 0, scm_acons); +#ifdef __STDC__ +SCM +scm_acons (SCM w, SCM x, SCM y) +#else +SCM +scm_acons (w, x, y) + SCM w; + SCM x; + SCM y; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CAR (z) = w; + SCM_CDR (z) = x; + x = z; + SCM_NEWCELL (z); + SCM_CAR (z) = x; + SCM_CDR (z) = y; + return z; +} + + + +SCM_PROC (s_sloppy_assq, "sloppy-assq", 2, 0, 0, scm_sloppy_assq); +#ifdef __STDC__ +SCM +scm_sloppy_assq(SCM x, SCM alist) +#else +SCM +scm_sloppy_assq(x, alist) + SCM x; + SCM alist; +#endif +{ + SCM tmp; + for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) + { + if (SCM_CONSP(alist)) + { + 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); +#ifdef __STDC__ +SCM +scm_sloppy_assv(SCM x, SCM alist) +#else +SCM +scm_sloppy_assv(x, alist) + SCM x; + SCM alist; +#endif +{ + SCM tmp; + for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) + { + if (SCM_CONSP(alist)) + { + 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); +#ifdef __STDC__ +SCM +scm_sloppy_assoc(SCM x, SCM alist) +#else +SCM +scm_sloppy_assoc(x, alist) + SCM x; + SCM alist; +#endif +{ + SCM tmp; + for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) + { + if (SCM_CONSP(alist)) + { + 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); +#ifdef __STDC__ +SCM +scm_assq(SCM x, SCM alist) +#else +SCM +scm_assq(x, alist) + SCM x; + SCM alist; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_assv(SCM x, SCM alist) +#else +SCM +scm_assv(x, alist) + SCM x; + SCM alist; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_assoc(SCM x, SCM alist) +#else +SCM +scm_assoc(x, alist) + SCM x; + SCM alist; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_assq_ref (SCM alist, SCM key) +#else +SCM +scm_assq_ref (alist, key) + SCM alist; + SCM key; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_assv_ref (SCM alist, SCM key) +#else +SCM +scm_assv_ref (alist, key) + SCM alist; + SCM key; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_assoc_ref (SCM alist, SCM key) +#else +SCM +scm_assoc_ref (alist, key) + SCM alist; + SCM key; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_assq_set_x (SCM alist, SCM key, SCM val) +#else +SCM +scm_assq_set_x (alist, key, val) + SCM alist; + SCM key; + SCM val; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_assv_set_x (SCM alist, SCM key, SCM val) +#else +SCM +scm_assv_set_x (alist, key, val) + SCM alist; + SCM key; + SCM val; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_assoc_set_x (SCM alist, SCM key, SCM val) +#else +SCM +scm_assoc_set_x (alist, key, val) + SCM alist; + SCM key; + SCM val; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_assq_remove_x (SCM alist, SCM key) +#else +SCM +scm_assq_remove_x (alist, key) + SCM alist; + SCM key; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_assv_remove_x (SCM alist, SCM key) +#else +SCM +scm_assv_remove_x (alist, key) + SCM alist; + SCM key; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_assoc_remove_x (SCM alist, SCM key) +#else +SCM +scm_assoc_remove_x (alist, key) + SCM alist; + SCM key; +#endif +{ + SCM handle; + + handle = scm_sloppy_assoc (key, alist); + if (SCM_NIMP (handle) && SCM_CONSP (handle)) + { + return scm_delete_x (handle, alist); + } + else + return alist; +} + + + + + +#ifdef __STDC__ +void +scm_init_alist (void) +#else +void +scm_init_alist () +#endif +{ +#include "alist.x" +} + diff --git a/libguile/alist.h b/libguile/alist.h new file mode 100644 index 000000000..f0f90a4df --- /dev/null +++ b/libguile/alist.h @@ -0,0 +1,97 @@ +/* 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 "__scm.h" + + + + + + +#ifdef __STDC__ +extern SCM scm_acons (SCM w, SCM x, SCM y); +extern SCM scm_sloppy_assq(SCM x, SCM alist); +extern SCM scm_sloppy_assv(SCM x, SCM alist); +extern SCM scm_sloppy_assoc(SCM x, SCM alist); +extern SCM scm_assq(SCM x, SCM alist); +extern SCM scm_assv(SCM x, SCM alist); +extern SCM scm_assoc(SCM x, SCM alist); +extern SCM scm_assq_ref (SCM alist, SCM key); +extern SCM scm_assv_ref (SCM alist, SCM key); +extern SCM scm_assoc_ref (SCM alist, SCM key); +extern SCM scm_assq_set_x (SCM alist, SCM key, SCM val); +extern SCM scm_assv_set_x (SCM alist, SCM key, SCM val); +extern SCM scm_assoc_set_x (SCM alist, SCM key, SCM val); +extern SCM scm_assq_remove_x (SCM alist, SCM key); +extern SCM scm_assv_remove_x (SCM alist, SCM key); +extern SCM scm_assoc_remove_x (SCM alist, SCM key); +extern void scm_init_alist (void); + +#else /* STDC */ +extern SCM scm_acons (); +extern SCM scm_sloppy_assq(); +extern SCM scm_sloppy_assv(); +extern SCM scm_sloppy_assoc(); +extern SCM scm_assq(); +extern SCM scm_assv(); +extern SCM scm_assoc(); +extern SCM scm_assq_ref (); +extern SCM scm_assv_ref (); +extern SCM scm_assoc_ref (); +extern SCM scm_assq_set_x (); +extern SCM scm_assv_set_x (); +extern SCM scm_assoc_set_x (); +extern SCM scm_assq_remove_x (); +extern SCM scm_assv_remove_x (); +extern SCM scm_assoc_remove_x (); +extern void scm_init_alist (); + +#endif /* STDC */ + + + + +#endif /* ALISTH */ diff --git a/libguile/append.c b/libguile/append.c new file mode 100644 index 000000000..4f09a1dcf --- /dev/null +++ b/libguile/append.c @@ -0,0 +1,88 @@ +/* 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" + + + +SCM_PROC (s_append, "append", 0, 0, 1, scm_append); +#ifdef __STDC__ +SCM +scm_append (SCM objs) +#else +SCM +scm_append (objs) + SCM objs; +#endif +{ + return scm_list_append (objs); +} + + +SCM_PROC (s_append_x, "append!", 0, 0, 1, scm_append_x); +#ifdef __STDC__ +SCM +scm_append_x (SCM objs) +#else +SCM +scm_append_x (objs) + SCM objs; +#endif +{ + return scm_list_append_x (objs); +} + + + + +#ifdef __STDC__ +void +scm_init_append (void) +#else +void +scm_init_append () +#endif +{ +#include "append.x" +} + diff --git a/libguile/append.h b/libguile/append.h new file mode 100644 index 000000000..33197f976 --- /dev/null +++ b/libguile/append.h @@ -0,0 +1,68 @@ +/* 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 "__scm.h" + + + + + + +#ifdef __STDC__ +extern SCM scm_append (SCM objs); +extern SCM scm_append_x (SCM objs); +extern void scm_init_append (void); + +#else /* STDC */ +extern SCM scm_append (); +extern SCM scm_append_x (); +extern void scm_init_append (); + +#endif /* STDC */ + + + +#endif /* APPENDH */ diff --git a/libguile/appinit.c b/libguile/appinit.c new file mode 100644 index 000000000..3af008123 --- /dev/null +++ b/libguile/appinit.c @@ -0,0 +1,57 @@ +/* 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" + + + +#ifdef __STDC__ +void +scm_appinit (void) +#else +void +scm_appinit () +#endif +{ +} + diff --git a/libguile/arbiters.c b/libguile/arbiters.c new file mode 100644 index 000000000..d5e374b42 --- /dev/null +++ b/libguile/arbiters.c @@ -0,0 +1,150 @@ +/* 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" + + +/* {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; + +#ifdef __STDC__ +static int +prinarb (SCM exp, SCM port, int writing) +#else +static int +prinarb (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + 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, writing); + 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); +#ifdef __STDC__ +SCM +scm_make_arbiter (SCM name) +#else +SCM +scm_make_arbiter (name) + SCM name; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CDR (z) = name; + SCM_CAR (z) = scm_tc16_arbiter; + return z; +} + +SCM_PROC(s_try_arbiter, "try-arbiter", 1, 0, 0, scm_try_arbiter); +#ifdef __STDC__ +SCM +scm_try_arbiter (SCM arb) +#else +SCM +scm_try_arbiter (arb) + SCM arb; +#endif +{ + 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_CAR (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); +#ifdef __STDC__ +SCM +scm_release_arbiter (SCM arb) +#else +SCM +scm_release_arbiter (arb) + SCM arb; +#endif +{ + 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_CAR (arb) = scm_tc16_arbiter; + return SCM_BOOL_T; +} + + +#ifdef __STDC__ +void +scm_init_arbiters (void) +#else +void +scm_init_arbiters () +#endif +{ + scm_tc16_arbiter = scm_newsmob (&arbsmob); +#include "arbiters.x" +} + diff --git a/libguile/arbiters.h b/libguile/arbiters.h new file mode 100644 index 000000000..2a88a6ebc --- /dev/null +++ b/libguile/arbiters.h @@ -0,0 +1,68 @@ +/* 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 "__scm.h" + + +#ifdef __STDC__ +extern SCM scm_make_arbiter (SCM name); +extern SCM scm_try_arbiter (SCM arb); +extern SCM scm_release_arbiter (SCM arb); +extern void scm_init_arbiters (void); + +#else /* STDC */ +extern SCM scm_make_arbiter (); +extern SCM scm_try_arbiter (); +extern SCM scm_release_arbiter (); +extern void scm_init_arbiters (); + +#endif /* STDC */ + + + + + +#endif /* ARBITERSH */ diff --git a/libguile/async.c b/libguile/async.c new file mode 100644 index 000000000..7a942270e --- /dev/null +++ b/libguile/async.c @@ -0,0 +1,737 @@ +/* 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" + +#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. + * + */ + + +#define min(A,B) ((A) < (B) ? (A) : (B)) + + +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)) + + + + + + +#ifdef __STDC__ +static int +asyncs_pending (void) +#else +static int +asyncs_pending () +#endif +{ + 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; +} + + +#ifdef __STDC__ +void +scm_async_click (void) +#else +void +scm_async_click () +#endif +{ + 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 (); +} + + + + +#ifdef __STDC__ +void +scm_switch (void) +#else +void +scm_switch () +#endif +{} + + +#ifdef __STDC__ +static void +scm_deliver_signal (int num) +#else +static void +scm_deliver_signal (num) + int num; +#endif +{ + 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)); + } +} + + + + +#ifdef __STDC__ +static int +print_async (SCM exp, SCM port, int writing) +#else +static int +print_async (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + scm_gen_puts (scm_regular_string, "#<async ", port); + scm_intprint(exp, 16, port); + scm_gen_putc('>', port); + return 1; +} + +#ifdef __STDC__ +static SCM +mark_async (SCM obj) +#else +static SCM +mark_async (obj) + SCM obj; +#endif +{ + struct scm_async * it; + if (SCM_GC8MARKP (obj)) + return SCM_BOOL_F; + SCM_SETGC8MARK (obj); + it = SCM_ASYNC (obj); + return it->thunk; +} + +#ifdef __STDC__ +static scm_sizet +free_async (SCM obj) +#else +static scm_sizet +free_async (SCM obj) + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_async (SCM thunk) +#else +SCM +scm_async (thunk) + SCM thunk; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_system_async (SCM thunk) +#else +SCM +scm_system_async (thunk) + SCM thunk; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_async_mark (SCM a) +#else +SCM +scm_async_mark (a) + SCM a; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_system_async_mark (SCM a) +#else +SCM +scm_system_async_mark (a) + SCM a; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_run_asyncs (SCM list_of_a) +#else +SCM +scm_run_asyncs (list_of_a) + SCM list_of_a; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_noop (SCM args) +#else +SCM +scm_noop (args) + SCM args; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_set_tick_rate (SCM n) +#else +SCM +scm_set_tick_rate (n) + SCM n; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_set_switch_rate (SCM n) +#else +SCM +scm_set_switch_rate (n) + SCM n; +#endif +{ + 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); +} + + + +#ifdef __STDC__ +static SCM +scm_sys_hup_async_thunk (void) +#else +static SCM +scm_sys_hup_async_thunk () +#endif +{ + scm_deliver_signal (SCM_HUP_SIGNAL); + return SCM_BOOL_F; +} + +#ifdef __STDC__ +static SCM +scm_sys_int_async_thunk (void) +#else +static SCM +scm_sys_int_async_thunk () +#endif +{ + scm_deliver_signal (SCM_INT_SIGNAL); + return SCM_BOOL_F; +} + +#ifdef __STDC__ +static SCM +scm_sys_fpe_async_thunk (void) +#else +static SCM +scm_sys_fpe_async_thunk () +#endif +{ + scm_deliver_signal (SCM_FPE_SIGNAL); + return SCM_BOOL_F; +} + +#ifdef __STDC__ +static SCM +scm_sys_bus_async_thunk (void) +#else +static SCM +scm_sys_bus_async_thunk () +#endif +{ + scm_deliver_signal (SCM_BUS_SIGNAL); + return SCM_BOOL_F; +} + +#ifdef __STDC__ +static SCM +scm_sys_segv_async_thunk (void) +#else +static SCM +scm_sys_segv_async_thunk () +#endif +{ + scm_deliver_signal (SCM_SEGV_SIGNAL); + return SCM_BOOL_F; +} + +#ifdef __STDC__ +static SCM +scm_sys_alrm_async_thunk (void) +#else +static SCM +scm_sys_alrm_async_thunk () +#endif +{ + scm_deliver_signal (SCM_ALRM_SIGNAL); + return SCM_BOOL_F; +} + +#ifdef __STDC__ +static SCM +scm_sys_gc_async_thunk (void) +#else +static SCM +scm_sys_gc_async_thunk () +#endif +{ + scm_deliver_signal (SCM_GC_SIGNAL); + return SCM_BOOL_F; +} + +#ifdef __STDC__ +static SCM +scm_sys_tick_async_thunk (void) +#else +static SCM +scm_sys_tick_async_thunk () +#endif +{ + scm_deliver_signal (SCM_TICK_SIGNAL); + return SCM_BOOL_F; +} + + + + + +#ifdef __STDC__ +SCM +scm_take_signal (int n) +#else +SCM +scm_take_signal (n) + int n; +#endif +{ + SCM ignored; + if (!scm_ints_disabled) + { + SCM_NEWCELL (ignored); /* In case we interrupted SCM_NEWCELL, + * throw out the possibly already allocated + * free cell. + */ + } + 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); +#ifdef __STDC__ +SCM +scm_unmask_signals (void) +#else +SCM +scm_unmask_signals () +#endif +{ + scm_mask_ints = 0; + return SCM_UNSPECIFIED; +} + + +SCM_PROC(s_mask_signals, "mask-signals", 0, 0, 0, scm_mask_signals); +#ifdef __STDC__ +SCM +scm_mask_signals (void) +#else +SCM +scm_mask_signals () +#endif +{ + scm_mask_ints = 1; + return SCM_UNSPECIFIED; +} + + + +#ifdef __STDC__ +void +scm_init_async (void) +#else +void +scm_init_async () +#endif +{ + SCM a_thunk; + scm_tc16_async = scm_newsmob (&async_smob); + symbol_signal = SCM_CAR (scm_sysintern ("signal", strlen ("signal"))); + 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", strlen ("signal")); + 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 new file mode 100644 index 000000000..2e99025ac --- /dev/null +++ b/libguile/async.h @@ -0,0 +1,91 @@ +/* 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 "__scm.h" + + + + +extern unsigned int scm_async_clock; +extern unsigned int scm_mask_ints; + + +#ifdef __STDC__ +extern void scm_async_click (void); +extern void scm_switch (void); +extern SCM scm_async (SCM thunk); +extern SCM scm_system_async (SCM thunk); +extern SCM scm_async_mark (SCM a); +extern SCM scm_system_async_mark (SCM a); +extern SCM scm_run_asyncs (SCM list_of_a); +extern SCM scm_noop (SCM args); +extern SCM scm_set_tick_rate (SCM n); +extern SCM scm_set_switch_rate (SCM n); +extern SCM scm_take_signal (int n); +extern SCM scm_unmask_signals (void); +extern SCM scm_mask_signals (void); +extern void scm_init_async (void); + +#else /* STDC */ +extern void scm_async_click (); +extern void scm_switch (); +extern SCM scm_async (); +extern SCM scm_system_async (); +extern SCM scm_async_mark (); +extern SCM scm_system_async_mark (); +extern SCM scm_run_asyncs (); +extern SCM scm_noop (); +extern SCM scm_set_tick_rate (); +extern SCM scm_set_switch_rate (); +extern SCM scm_take_signal (); +extern SCM scm_unmask_signals (); +extern SCM scm_mask_signals (); +extern void scm_init_async (); + +#endif /* STDC */ + + +#endif /* ASYNCH */ diff --git a/libguile/boolean.c b/libguile/boolean.c new file mode 100644 index 000000000..cc8c63382 --- /dev/null +++ b/libguile/boolean.c @@ -0,0 +1,88 @@ +/* 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" + + + +SCM_PROC(s_not, "not", 1, 0, 0, scm_not); +#ifdef __STDC__ +SCM +scm_not(SCM x) +#else +SCM +scm_not(x) + SCM x; +#endif +{ + return SCM_FALSEP(x) ? SCM_BOOL_T : SCM_BOOL_F; +} + + +SCM_PROC(s_boolean_p, "boolean?", 1, 0, 0, scm_boolean_p); +#ifdef __STDC__ +SCM +scm_boolean_p(SCM obj) +#else +SCM +scm_boolean_p(obj) + SCM obj; +#endif +{ + if (SCM_BOOL_F==obj) return SCM_BOOL_T; + if (SCM_BOOL_T==obj) return SCM_BOOL_T; + return SCM_BOOL_F; +} + + +#ifdef __STDC__ +void +scm_init_boolean (void) +#else +void +scm_init_boolean () +#endif +{ +#include "boolean.x" +} + diff --git a/libguile/boolean.h b/libguile/boolean.h new file mode 100644 index 000000000..8c9b6a7e7 --- /dev/null +++ b/libguile/boolean.h @@ -0,0 +1,76 @@ +/* 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 "__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)) + + + +#ifdef __STDC__ +extern SCM scm_not(SCM x); +extern SCM scm_boolean_p(SCM obj); +extern void scm_init_boolean (void); + +#else /* STDC */ +extern SCM scm_not(); +extern SCM scm_boolean_p(); +extern void scm_init_boolean (); + +#endif /* STDC */ + + +#endif /* BOOLEANH */ diff --git a/libguile/chars.c b/libguile/chars.c new file mode 100644 index 000000000..70ec0ab82 --- /dev/null +++ b/libguile/chars.c @@ -0,0 +1,507 @@ +/* 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" + + + + + +SCM_PROC(s_char_p, "char?", 1, 0, 0, scm_char_p); +#ifdef __STDC__ +SCM +scm_char_p(SCM x) +#else +SCM +scm_char_p(x) + SCM x; +#endif +{ + return SCM_ICHRP(x) ? SCM_BOOL_T : SCM_BOOL_F; +} + +SCM_PROC1 (s_char_eq_p, "char=?", scm_tc7_rpsubr, scm_char_eq_p); +#ifdef __STDC__ +SCM +scm_char_eq_p(SCM x, SCM y) +#else +SCM +scm_char_eq_p(x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_less_p(SCM x, SCM y) +#else +SCM +scm_char_less_p(x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_leq_p(SCM x, SCM y) +#else +SCM +scm_char_leq_p(x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_gr_p(SCM x, SCM y) +#else +SCM +scm_char_gr_p(x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_geq_p(SCM x, SCM y) +#else +SCM +scm_char_geq_p(x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_ci_eq_p(SCM x, SCM y) +#else +SCM +scm_char_ci_eq_p(x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_ci_less_p(SCM x, SCM y) +#else +SCM +scm_char_ci_less_p(x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_ci_leq_p(SCM x, SCM y) +#else +SCM +scm_char_ci_leq_p(x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_ci_gr_p(SCM x, SCM y) +#else +SCM +scm_char_ci_gr_p(x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_ci_geq_p(SCM x, SCM y) +#else +SCM +scm_char_ci_geq_p(x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_alphabetic_p(SCM chr) +#else +SCM +scm_char_alphabetic_p(chr) + SCM chr; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_numeric_p(SCM chr) +#else +SCM +scm_char_numeric_p(chr) + SCM chr; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_whitespace_p(SCM chr) +#else +SCM +scm_char_whitespace_p(chr) + SCM chr; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_upper_case_p(SCM chr) +#else +SCM +scm_char_upper_case_p(chr) + SCM chr; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_lower_case_p(SCM chr) +#else +SCM +scm_char_lower_case_p(chr) + SCM chr; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_is_both_p (SCM chr) +#else +SCM +scm_char_is_both_p (chr) + SCM chr; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_to_integer(SCM chr) +#else +SCM +scm_char_to_integer(chr) + SCM chr; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_integer_to_char(SCM n) +#else +SCM +scm_integer_to_char(n) + SCM n; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_upcase(SCM chr) +#else +SCM +scm_char_upcase(chr) + SCM chr; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_char_downcase(SCM chr) +#else +SCM +scm_char_downcase(chr) + SCM chr; +#endif +{ + 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_SCM_CODE_LIMIT]; +static unsigned char scm_downcase_table[SCM_CHAR_SCM_CODE_LIMIT]; +static unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz"; +static unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; + +#ifdef __STDC__ +void +scm_tables_prehistory (void) +#else +void +scm_tables_prehistory () +#endif +{ + int i; + for (i = 0; i < SCM_CHAR_SCM_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]; + } +} + +#ifdef __STDC__ +int +scm_upcase (unsigned int c) +#else +int +scm_upcase (c) + unsigned int c; +#endif +{ + if (c < sizeof (scm_upcase_table)) + return scm_upcase_table[c]; + else + return c; +} + +#ifdef __STDC__ +int +scm_downcase (unsigned int c) +#else +int +scm_downcase (c) + unsigned int c; +#endif +{ + 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 *); + + + + +#ifdef __STDC__ +void +scm_init_chars (void) +#else +void +scm_init_chars () +#endif +{ +#include "chars.x" +} + diff --git a/libguile/chars.h b/libguile/chars.h new file mode 100644 index 000000000..83afcfa7e --- /dev/null +++ b/libguile/chars.h @@ -0,0 +1,126 @@ +/* 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 "__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[]; + + +#ifdef __STDC__ +extern SCM scm_char_p(SCM x); +extern SCM scm_char_eq_p(SCM x, SCM y); +extern SCM scm_char_less_p(SCM x, SCM y); +extern SCM scm_char_leq_p(SCM x, SCM y); +extern SCM scm_char_gr_p(SCM x, SCM y); +extern SCM scm_char_geq_p(SCM x, SCM y); +extern SCM scm_char_ci_eq_p(SCM x, SCM y); +extern SCM scm_char_ci_less_p(SCM x, SCM y); +extern SCM scm_char_ci_leq_p(SCM x, SCM y); +extern SCM scm_char_ci_gr_p(SCM x, SCM y); +extern SCM scm_char_ci_geq_p(SCM x, SCM y); +extern SCM scm_char_alphabetic_p(SCM chr); +extern SCM scm_char_numeric_p(SCM chr); +extern SCM scm_char_whitespace_p(SCM chr); +extern SCM scm_char_upper_case_p(SCM chr); +extern SCM scm_char_lower_case_p(SCM chr); +extern SCM scm_char_is_both_p (SCM chr); +extern SCM scm_char_to_integer(SCM chr); +extern SCM scm_integer_to_char(SCM n); +extern SCM scm_char_upcase(SCM chr); +extern SCM scm_char_downcase(SCM chr); +extern void scm_tables_prehistory (void); +extern int scm_upcase (unsigned int c); +extern int scm_downcase (unsigned int c); +extern void scm_init_chars (void); + +#else /* STDC */ +extern SCM scm_char_p(); +extern SCM scm_char_eq_p(); +extern SCM scm_char_less_p(); +extern SCM scm_char_leq_p(); +extern SCM scm_char_gr_p(); +extern SCM scm_char_geq_p(); +extern SCM scm_char_ci_eq_p(); +extern SCM scm_char_ci_less_p(); +extern SCM scm_char_ci_leq_p(); +extern SCM scm_char_ci_gr_p(); +extern SCM scm_char_ci_geq_p(); +extern SCM scm_char_alphabetic_p(); +extern SCM scm_char_numeric_p(); +extern SCM scm_char_whitespace_p(); +extern SCM scm_char_upper_case_p(); +extern SCM scm_char_lower_case_p(); +extern SCM scm_char_is_both_p (); +extern SCM scm_char_to_integer(); +extern SCM scm_integer_to_char(); +extern SCM scm_char_upcase(); +extern SCM scm_char_downcase(); +extern void scm_tables_prehistory (); +extern int scm_upcase (); +extern int scm_downcase (); +extern void scm_init_chars (); + +#endif /* STDC */ + + + + + + + + +#endif /* SCM_CHARSH */ diff --git a/libguile/configure b/libguile/configure new file mode 100755 index 000000000..83e29e67b --- /dev/null +++ b/libguile/configure @@ -0,0 +1,1994 @@ +#! /bin/sh + +# Guess values for system-dependent variables and create Makefiles. +# Generated automatically using autoconf version 2.9 +# 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= + +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.9" + 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 LANG and LC_ALL to C if already set. +# These must not be set unconditionally because not all systems understand +# e.g. LANG=C (notably SCO). +if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi +if test "${LANG+set}" = set; then LANG=C; export LANG; 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' + +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 + +test -z "$CFLAGS" && CFLAGS=-g +test -z "$LDFLAGS" && LDFLAGS=-g + +# 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 +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 +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 we are using GNU C""... $ac_c" 1>&6 +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:609: \"$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 + if test "${CFLAGS+set}" != set; then + echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_prog_gcc_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_gcc_g=yes +else + ac_cv_prog_gcc_g=no +fi +rm -f conftest* + +fi + +echo "$ac_t""$ac_cv_prog_gcc_g" 1>&6 + if test $ac_cv_prog_gcc_g = yes; then + CFLAGS="-g -O" + else + CFLAGS="-O" + fi + fi +else + GCC= + test "${CFLAGS+set}" = set || CFLAGS="-g" +fi + +echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 +# 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 661 "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:667: \"$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 + rm -rf conftest* + CPP="${CC-cc} -E -traditional-cpp" + cat > conftest.$ac_ext <<EOF +#line 676 "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:682: \"$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 + 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 +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 +cat > conftest.$ac_ext <<EOF +#line 733 "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 +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" | tr './\055' '___'` +echo $ac_n "checking for minix/config.h""... $ac_c" 1>&6 +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 780 "configure" +#include "confdefs.h" +#include <minix/config.h> +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:785: \"$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 + 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 for working const""... $ac_c" 1>&6 +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 826 "configure" +#include "confdefs.h" + +int main() { return 0; } +int t() { + +/* 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:876: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_c_const=yes +else + 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 + + +# If we cannot run a trivial program, we must be cross compiling. +echo $ac_n "checking whether cross-compiling""... $ac_c" 1>&6 +if eval "test \"`echo '$''{'ac_cv_c_cross'+set}'`\" = set"; then + echo $ac_n "(cached) $ac_c" 1>&6 +else + if test "$cross_compiling" = yes; then + ac_cv_c_cross=yes +else +cat > conftest.$ac_ext <<EOF +#line 905 "configure" +#include "confdefs.h" +main(){return(0);} +EOF +{ (eval echo configure:909: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } +if test -s conftest && (./conftest; exit) 2>/dev/null; then + ac_cv_c_cross=no +else + ac_cv_c_cross=yes +fi +fi +rm -fr conftest* +fi + +echo "$ac_t""$ac_cv_c_cross" 1>&6 +cross_compiling=$ac_cv_c_cross + +echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 +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 927 "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:935: \"$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 + 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 950 "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 968 "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 989 "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 +{ (eval echo configure:1000: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } +if test -s conftest && (./conftest; exit) 2>/dev/null; then + : +else + ac_cv_header_stdc=no +fi +fi +rm -fr conftest* +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" | tr './\055' '___'` +echo $ac_n "checking for $ac_hdr that defines DIR""... $ac_c" 1>&6 +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 1028 "configure" +#include "confdefs.h" +#include <sys/types.h> +#include <$ac_hdr> +int main() { return 0; } +int t() { +DIR *dirp = 0; +; return 0; } +EOF +if { (eval echo configure:1037: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + eval "ac_cv_header_dirent_$ac_safe=yes" +else + 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 | tr 'abcdedfghijklmnopqrstuvwxyz./\055' 'ABCDEDFGHIJKLMNOPQRSTUVWXYZ___'` + 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 -ldir""... $ac_c" 1>&6 +ac_lib_var=`echo dir_opendir | tr '.-/+' '___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 1068 "configure" +#include "confdefs.h" +/* Override any gcc2 internal prototype to avoid an error. */ +char opendir(); + +int main() { return 0; } +int t() { +opendir() +; return 0; } +EOF +if { (eval echo configure:1078: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + 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 -lx""... $ac_c" 1>&6 +ac_lib_var=`echo x_opendir | tr '.-/+' '___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 1105 "configure" +#include "confdefs.h" +/* Override any gcc2 internal prototype to avoid an error. */ +char opendir(); + +int main() { return 0; } +int t() { +opendir() +; return 0; } +EOF +if { (eval echo configure:1115: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then + rm -rf conftest* + eval "ac_cv_lib_$ac_lib_var=yes" +else + 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 +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 1140 "configure" +#include "confdefs.h" +#include <sys/types.h> +#include <sys/time.h> +#include <time.h> +int main() { return 0; } +int t() { +struct tm *tp; +; return 0; } +EOF +if { (eval echo configure:1150: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_header_time=yes +else + 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 +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 1174 "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() { return 0; } +int t() { +int s; +wait (&s); +s = WIFEXITED (s) ? WEXITSTATUS (s) : 1; +; return 0; } +EOF +if { (eval echo configure:1191: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_header_sys_wait_h=yes +else + 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 unistd.h string.h malloc.h memory.h limits.h time.h sys/types.h sys/select.h sys/time.h sys/timeb.h sys/times.h +do +ac_safe=`echo "$ac_hdr" | tr './\055' '___'` +echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 +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 1218 "configure" +#include "confdefs.h" +#include <$ac_hdr> +EOF +ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" +{ (eval echo configure:1223: \"$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 + 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 | tr 'abcdefghijklmnopqrstuvwxyz./\055' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ___'` + cat >> confdefs.h <<EOF +#define $ac_tr_hdr 1 +EOF + +else + echo "$ac_t""no" 1>&6 +fi +done + + +echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 +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 1253 "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 +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 1289 "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 +{ (eval echo configure:1314: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } +if test -s conftest && (./conftest; exit) 2>/dev/null; then + ac_cv_type_getgroups=gid_t +else + ac_cv_type_getgroups=int +fi +fi +rm -fr conftest* +if test $ac_cv_type_getgroups = cross; then + cat > conftest.$ac_ext <<EOF +#line 1324 "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 +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 1352 "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() { return 0; } +int t() { +int i; +; return 0; } +EOF +if { (eval echo configure:1370: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_type_signal=void +else + 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 + + + +for ac_func in ftime times geteuid select uname mkdir rmdir getcwd rename putenv setlocale strftime strptime mknod nice lstat readlink symlink sync +do +echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 +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 1395 "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. */ +char $ac_func(); + +int main() { return 0; } +int t() { + +/* 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:1417: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then + rm -rf conftest* + eval "ac_cv_func_$ac_func=yes" +else + 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 +do +echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 +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 1447 "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. */ +char $ac_func(); + +int main() { return 0; } +int t() { + +/* 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:1469: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then + rm -rf conftest* + eval "ac_cv_func_$ac_func=yes" +else + 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 + : +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 +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 1495 "configure" +#include "confdefs.h" +#include <sys/types.h> +#include <sys/stat.h> +int main() { return 0; } +int t() { +struct stat s; s.st_rdev; +; return 0; } +EOF +if { (eval echo configure:1504: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_struct_st_rdev=yes +else + 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 +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 1528 "configure" +#include "confdefs.h" +#include <sys/types.h> +#include <sys/stat.h> +int main() { return 0; } +int t() { +struct stat s; s.st_blksize; +; return 0; } +EOF +if { (eval echo configure:1537: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_struct_st_blksize=yes +else + 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 +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 1561 "configure" +#include "confdefs.h" +#include <sys/types.h> +#include <sys/stat.h> +int main() { return 0; } +int t() { +struct stat s; s.st_blocks; +; return 0; } +EOF +if { (eval echo configure:1570: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + ac_cv_struct_st_blocks=yes +else + 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 + + +#-------------------------------------------------------------------- +# +# 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 1602 "configure" +#include "confdefs.h" +aux (l) unsigned long l; + { int x; exit (l >= ((unsigned long)&x)); } + main () { int q; aux((unsigned long)&q); } +EOF +{ (eval echo configure:1608: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } +if test -s conftest && (./conftest; exit) 2>/dev/null; then + cat >> confdefs.h <<\EOF +#define SCM_STACK_GROWS_UP 1 +EOF + +fi +fi +rm -fr conftest* + + +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 1627 "configure" +#include "confdefs.h" +main () { exit (sizeof(float) != sizeof(long)); } +EOF +{ (eval echo configure:1631: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } +if test -s conftest && (./conftest; exit) 2>/dev/null; then + cat >> confdefs.h <<\EOF +#define SCM_SINGLES 1 +EOF + +fi +fi +rm -fr conftest* + + + + +#-------------------------------------------------------------------- +# +# 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 1654 "configure" +#include "confdefs.h" +#include <stdio.h> + +int main() { return 0; } +int t() { +stdout->_file = 1 +; return 0; } +EOF +if { (eval echo configure:1663: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + FD_SETTER="((F)->_file = (D))" +fi +rm -f conftest* + +fi + +if test "x$FD_SETTER" = x; then + cat > conftest.$ac_ext <<EOF +#line 1673 "configure" +#include "confdefs.h" +#include <stdio.h> + +int main() { return 0; } +int t() { +stdout->_fileno +; return 0; } +EOF +if { (eval echo configure:1682: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then + rm -rf conftest* + FD_SETTER="((F)->_fileno = (D))" +fi +rm -f conftest* + +fi + + +test "x$FD_SETTER" != x && cat >> confdefs.h <<\EOF +#define HAVE_FD_SETTER 1 +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 +# 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 | + sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \ + >> 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.9" + 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 + +trap 'rm -fr `echo "Makefile fd.h 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%@CC@%$CC%g +s%@CPP@%$CPP%g +s%@RANLIB@%$RANLIB%g +s%@LIBOBJS@%$LIBOBJS%g +s%@FD_SETTER@%$FD_SETTER%g +s%@TCL_SRC_DIR@%$TCL_SRC_DIR%g +s%@TK_SRC_DIR@%$TK_SRC_DIR%g +s%@XINCLUDES@%$XINCLUDES%g +s%@GUILE_MAJOR_VERSION@%$GUILE_MAJOR_VERSION%g +s%@GUILE_MINOR_VERSION@%$GUILE_MINOR_VERSION%g +s%@GUILE_VERSION@%$GUILE_VERSION%g + +CEOF +EOF +cat >> $CONFIG_STATUS <<EOF + +CONFIG_FILES=\${CONFIG_FILES-"Makefile fd.h"} +EOF +cat >> $CONFIG_STATUS <<\EOF +for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then + # Support "outfile[: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 relative srcdir, etc. 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 + + 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 + sed -e "$ac_comsub +s%@configure_input@%$configure_input%g +s%@srcdir@%$srcdir%g +s%@top_srcdir@%$top_srcdir%g +" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file +fi; done +rm -f conftest.subs + +# 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' + +CONFIG_HEADERS=${CONFIG_HEADERS-"scmconfig.h"} +for ac_file in .. $CONFIG_HEADERS; do if test "x$ac_file" != x..; then + # Support "outfile[: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 + cp $ac_given_srcdir/$ac_file_in 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. +# Maximum number of lines to put in a single here document. +ac_max_here_lines=12 + +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 + rm -f $ac_file + mv conftest.h $ac_file + fi +fi; done + + + +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 new file mode 100644 index 000000000..ae71726d5 --- /dev/null +++ b/libguile/configure.in @@ -0,0 +1,107 @@ +AC_INIT(eval.c) +AC_CONFIG_HEADER(scmconfig.h) + +. $srcdir/../GUILE-VERSION + +test -z "$CFLAGS" && CFLAGS=-g +test -z "$LDFLAGS" && LDFLAGS=-g + +AC_PROG_CC +AC_PROG_CPP +AC_PROG_RANLIB + +AC_AIX +AC_ISC_POSIX +AC_MINIX + +AC_C_CONST + +AC_HEADER_STDC +AC_HEADER_DIRENT +AC_HEADER_TIME +AC_HEADER_SYS_WAIT +AC_CHECK_HEADERS(unistd.h string.h malloc.h memory.h limits.h time.h sys/types.h sys/select.h sys/time.h sys/timeb.h sys/times.h) + +AC_TYPE_GETGROUPS +AC_TYPE_SIGNAL + +AC_CHECK_FUNCS(ftime times geteuid seteuid setegid select uname mkdir rmdir getcwd rename putenv setlocale strftime strptime mknod nice lstat readlink symlink sync) + +AC_REPLACE_FUNCS(inet_aton) + +AC_STRUCT_ST_RDEV +AC_STRUCT_ST_BLKSIZE +AC_STRUCT_ST_BLOCKS + +#-------------------------------------------------------------------- +# +# 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)) + + + + +#-------------------------------------------------------------------- +# +# 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) + + + +AC_SUBST(CFLAGS) +AC_SUBST(LDFLAGS) +AC_SUBST(LIBOBJS) +AC_SUBST(FD_SETTER) +AC_SUBST(TCL_SRC_DIR) +AC_SUBST(TK_SRC_DIR) +AC_SUBST(XINCLUDES) +AC_SUBST(GUILE_MAJOR_VERSION) +AC_SUBST(GUILE_MINOR_VERSION) +AC_SUBST(GUILE_VERSION) +AC_OUTPUT(Makefile fd.h) + +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 new file mode 100644 index 000000000..054ed8e56 --- /dev/null +++ b/libguile/continuations.c @@ -0,0 +1,227 @@ +/* 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" + + + +/* {Continuations} + */ + +static char s_cont[] = "continuation"; + +#ifdef __STDC__ +SCM +scm_make_cont (SCM * answer) +#else +SCM +scm_make_cont (answer) + SCM * answer; +#endif +{ + long j; + SCM cont; + +#ifdef CHEAP_CONTINUATIONS + SCM_NEWCELL (cont); + *answer = cont; + SCM_DEFER_INTS; + SCM_SETJMPBUF (cont, scm_must_malloc ((long) sizeof (regs), s_cont)); + SCM_CAR (cont) = scm_tc7_contin; + SCM_DYNENV (cont) = 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; + + { + SCM winds; + + for (winds = scm_dynwinds; winds != SCM_EOL; winds = SCM_CDR (winds)) + { +#if 0 + 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 (regs) + 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 (regs)); + for (j = SCM_LENGTH (cont); 0 <= --j;) + *dst++ = *src++; +#endif /* def CHEAP_CONTINUATIONS */ +#ifdef DEBUG_EXTENSIONS + SCM_DFRAME (cont) = last_debug_info_frame; +#endif + return cont; +} + + +void scm_dynthrow SCM_P ((SCM *a)); + +/* Grow the stack so that there is room */ +/* to copy in the continuation. Then */ +#ifndef CHEAP_CONTINUATIONS +#ifdef __STDC__ +static void +grow_throw (SCM *a) +#else +static void +grow_throw (a) + SCM *a; +#endif +{ /* 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 */ + +#ifdef __STDC__ +void +scm_dynthrow (SCM *a) +#else +void +scm_dynthrow (a) + SCM *a; +#endif +{ + 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 (regs)); + 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 + last_debug_info_frame = SCM_DFRAME (cont); +#endif + SCM_THROW_VALUE(cont) = val; + longjmp (SCM_JMPBUF (cont), 1); +} + +#ifdef __STDC__ +SCM +scm_call_continuation (SCM cont, SCM val) +#else +SCM +scm_call_continuation (cont, val) + SCM cont; + SCM val; +#endif +{ + 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 */ +} + + +#ifdef __STDC__ +void +scm_init_continuations (void) +#else +void +scm_init_continuations () +#endif +{ +#include "continuations.x" +} + diff --git a/libguile/continuations.h b/libguile/continuations.h new file mode 100644 index 000000000..176d423fc --- /dev/null +++ b/libguile/continuations.h @@ -0,0 +1,86 @@ +/* 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 "__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 +} regs; + +#define SCM_JMPBUF(x) (((regs *)SCM_CHARS(x))->jmpbuf) +#define SCM_SETJMPBUF SCM_SETCDR +#define SCM_DYNENV(x) (((regs *)SCM_CHARS(x))->dynenv) +#define SCM_THROW_VALUE(x) (((regs *)SCM_CHARS(x))->throw_value) +#define SCM_BASE(x) (((regs *)SCM_CHARS(x))->base) +#define SCM_SEQ(x) (((regs *)SCM_CHARS(x))->seq) +#define SCM_DFRAME(x) (((regs *)SCM_CHARS(x))->dframe) + + + +#ifdef __STDC__ +extern SCM scm_make_cont (SCM * answer); +extern void scm_dynthrow (SCM *a); +extern SCM scm_call_continuation (SCM cont, SCM val); +extern void scm_init_continuations (void); + +#else /* STDC */ +extern SCM scm_make_cont (); +extern void scm_dynthrow (); +extern SCM scm_call_continuation (); +extern void scm_init_continuations (); + +#endif /* STDC */ +#endif /* CONTINUATIONSH */ diff --git a/libguile/def.sed b/libguile/def.sed new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/libguile/def.sed diff --git a/libguile/dynwind.c b/libguile/dynwind.c new file mode 100644 index 000000000..b80a00c76 --- /dev/null +++ b/libguile/dynwind.c @@ -0,0 +1,148 @@ +/* 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" + + + +/* {Dynamic wind} + */ + + + +SCM_PROC(s_dynamic_wind, "dynamic-wind", 3, 0, 0, scm_dynamic_wind); +#ifdef __STDC__ +SCM +scm_dynamic_wind (SCM thunk1, SCM thunk2, SCM thunk3) +#else +SCM +scm_dynamic_wind (thunk1, thunk2, thunk3) + SCM thunk1; + SCM thunk2; + SCM thunk3; +#endif +{ + 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; +} + +#ifdef __STDC__ +void +scm_dowinds (SCM to, long delta) +#else +void +scm_dowinds (to, delta) + SCM to; + long delta; +#endif +{ + 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); */ + } +} + + +#ifdef __STDC__ +void +scm_init_dynwind (void) +#else +void +scm_init_dynwind () +#endif +{ +#include "dynwind.x" +} + diff --git a/libguile/dynwind.h b/libguile/dynwind.h new file mode 100644 index 000000000..42f1515d2 --- /dev/null +++ b/libguile/dynwind.h @@ -0,0 +1,66 @@ +/* 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 "__scm.h" + + +#ifdef __STDC__ +extern SCM scm_dynamic_wind (SCM thunk1, SCM thunk2, SCM thunk3); +extern void scm_dowinds (SCM to, long delta); +extern void scm_init_dynwind (void); + +#else /* STDC */ +extern SCM scm_dynamic_wind (); +extern void scm_dowinds (); +extern void scm_init_dynwind (); + +#endif /* STDC */ + + + + + + +#endif /* DYNWINDH */ diff --git a/libguile/eq.c b/libguile/eq.c new file mode 100644 index 000000000..ed6dc4e12 --- /dev/null +++ b/libguile/eq.c @@ -0,0 +1,162 @@ +/* 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" + + +SCM_PROC1 (s_eq_p, "eq?", scm_tc7_rpsubr, scm_eq_p); +#ifdef __STDC__ +SCM +scm_eq_p (SCM x, SCM y) +#else +SCM +scm_eq_p (x, y) + SCM x; + SCM y; +#endif +{ + return ((x==y) + ? SCM_BOOL_T + : SCM_BOOL_F); +} + + +SCM_PROC1 (s_eqv_p, "eqv?", scm_tc7_rpsubr, scm_eqv_p); +#ifdef __STDC__ +SCM +scm_eqv_p (SCM x, SCM y) +#else +SCM +scm_eqv_p (x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_equal_p (SCM x, SCM y) +#else +SCM +scm_equal_p (x, y) + SCM x; + SCM y; +#endif +{ + 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; +} + + + + + +#ifdef __STDC__ +void +scm_init_eq (void) +#else +void +scm_init_eq () +#endif +{ +#include "eq.x" +} + diff --git a/libguile/eq.h b/libguile/eq.h new file mode 100644 index 000000000..db164ec0d --- /dev/null +++ b/libguile/eq.h @@ -0,0 +1,63 @@ +/* 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. + */ + + + + +#ifdef __STDC__ +extern SCM scm_eq_p (SCM x, SCM y); +extern SCM scm_eqv_p (SCM x, SCM y); +extern SCM scm_equal_p (SCM x, SCM y); +extern void scm_init_eq (void); + +#else /* STDC */ +extern SCM scm_eq_p (); +extern SCM scm_eqv_p (); +extern SCM scm_equal_p (); +extern void scm_init_eq (); + +#endif /* STDC */ + +#endif /* EQH */ diff --git a/libguile/error.c b/libguile/error.c new file mode 100644 index 000000000..c16612513 --- /dev/null +++ b/libguile/error.c @@ -0,0 +1,205 @@ +/* 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" + + + + +/* {Errors and Exceptional Conditions} + */ + +SCM system_error_sym; + +/* 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; +#ifdef __STDC__ +static void +err_head (char *str) +#else +static void +err_head (str) + char *str; +#endif +{ + 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_iprin1 (*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); +#ifdef __STDC__ +SCM +scm_errno (SCM arg) +#else +SCM +scm_errno (arg) + SCM arg; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_perror (SCM arg) +#else +SCM +scm_perror (arg) + SCM arg; +#endif +{ + SCM_ASSERT (SCM_NIMP (arg) && SCM_STRINGP (arg), arg, SCM_ARG1, s_perror); + err_head (SCM_CHARS (arg)); + return SCM_UNSPECIFIED; +} + + +#ifdef __STDC__ +void +scm_everr (SCM exp, SCM env, SCM arg, char *pos, char *s_subr) +#else +void +scm_everr (exp, env, arg, pos, s_subr) + SCM exp; + SCM env; + SCM arg; + char *pos; + char *s_subr; +#endif +{ + SCM desc; + SCM args; + + if ((~0x1fL) & (long) pos) + desc = scm_makfrom0str (pos); + else + desc = SCM_MAKINUM ((long)pos); + + { + SCM sym; + if (!s_subr || !*s_subr) + sym = SCM_BOOL_F; + else + sym = SCM_CAR (scm_intern0 (s_subr)); + args = scm_listify (desc, sym, arg, SCM_UNDEFINED); + } + + /* (throw (quote %%system-error) <desc> <proc-name> arg) + * + * <desc> is a string or an integer (see %%system-errors). + * <proc-name> is a symbol or #f in some annoying cases (e.g. cddr). + */ + + scm_ithrow (system_error_sym, args, 1); + + /* No return, but just in case: */ + + write (2, "unhandled system error", sizeof ("unhandled system error")); + exit (1); +} + +#ifdef __STDC__ +SCM +scm_wta (SCM arg, char *pos, char *s_subr) +#else +SCM +scm_wta (arg, pos, s_subr) + SCM arg; + char *pos; + char *s_subr; +#endif +{ + scm_everr (SCM_UNDEFINED, SCM_EOL, arg, pos, s_subr); + return SCM_UNSPECIFIED; +} + + + +#ifdef __STDC__ +void +scm_init_error (void) +#else +void +scm_init_error () +#endif +{ + system_error_sym = SCM_CAR (scm_intern0 ("%%system-error")); + scm_permanent_object (system_error_sym); +#include "error.x" +} + diff --git a/libguile/error.h b/libguile/error.h new file mode 100644 index 000000000..c635c5d13 --- /dev/null +++ b/libguile/error.h @@ -0,0 +1,79 @@ +/* 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 "__scm.h" +#include "pairs.h" + + + +extern int scm_ints_disabled; +extern SCM system_error_sym; + + + + +#ifdef __STDC__ +extern int scm_handle_it (int i); +extern void scm_warn (char *str1, char *str2); +extern SCM scm_errno (SCM arg); +extern SCM scm_perror (SCM arg); +extern void scm_def_err_response (void); +extern void scm_everr (SCM exp, SCM env, SCM arg, char *pos, char *s_subr); +extern SCM scm_wta (SCM arg, char *pos, char *s_subr); +extern void scm_init_error (void); + +#else /* STDC */ +extern int scm_handle_it (); +extern void scm_warn (); +extern SCM scm_errno (); +extern SCM scm_perror (); +extern void scm_def_err_response (); +extern void scm_everr (); +extern SCM scm_wta (); +extern void scm_init_error (); + +#endif /* STDC */ + +#endif /* ERRORH */ diff --git a/libguile/eval.c b/libguile/eval.c new file mode 100644 index 000000000..7b2f3600e --- /dev/null +++ b/libguile/eval.c @@ -0,0 +1,2513 @@ +/* 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 is read twice in order to produce a second debugging + * version of scm_ceval called scm_deval. scm_deval is produced when + * we define the preprocessor macro DEVAL. + */ + +#ifndef DEVAL + +#include <stdio.h> +#include "_scm.h" + + + +#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \ + ? *scm_lookupcar(x, env) \ + : SCM_CEVAL(SCM_CAR(x), env)) + +#ifdef MEMOIZE_LOCALS +#define EVALIMP(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x) +#else +#define EVALIMP(x, env) x +#endif +#define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\ + ? (SCM_IMP(SCM_CAR(x)) \ + ? EVALIMP(SCM_CAR(x), env) \ + : SCM_GLOC_VAL(SCM_CAR(x))) \ + : EVALCELLCAR(x, env)) +#ifdef DEBUG_EXTENSIONS +#define XEVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x)) \ + ? (SCM_IMP(SCM_CAR(x)) \ + ? EVALIMP(SCM_CAR(x), env) \ + : SCM_GLOC_VAL(SCM_CAR(x))) \ + : (SCM_SYMBOLP(SCM_CAR(x)) \ + ? *scm_lookupcar(x, env) \ + : (*scm_ceval_ptr) (SCM_CAR(x), env))) +#else +#define XEVALCAR(x, env) EVALCAR(x, env) +#endif + +#define EXTEND_SCM_ENV SCM_EXTEND_SCM_ENV + +#ifdef MEMOIZE_LOCALS +#ifdef __STDC__ +SCM * +scm_ilookup (SCM iloc, SCM env) +#else +SCM * +scm_ilookup (iloc, env) + SCM iloc; + SCM env; +#endif +{ + register int ir = SCM_IFRAME (iloc); + register SCM er = env; + for (; 0 != ir; --ir) + er = SCM_CDR (er); + er = SCM_CAR (er); + for (ir = SCM_IDIST (iloc); 0 != ir; --ir) + er = SCM_CDR (er); + if (SCM_ICDRP (iloc)) + return &SCM_CDR (er); + return &SCM_CAR (SCM_CDR (er)); +} +#endif + +#ifdef __STDC__ +SCM * +scm_lookupcar (SCM vloc, SCM genv) +#else +SCM * +scm_lookupcar (vloc, genv) + SCM vloc; + SCM genv; +#endif +{ + SCM env = genv; + register SCM *al, fl, var = SCM_CAR (vloc); +#ifdef MEMOIZE_LOCALS + register SCM iloc = SCM_ILOC00; +#endif + for (; SCM_NIMP (env); env = SCM_CDR (env)) + { + if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env))) + break; + al = &SCM_CAR (env); + for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl)) + { + if (SCM_NCONSP (fl)) + if (fl == var) + { +#ifdef MEMOIZE_LOCALS + SCM_CAR (vloc) = iloc + SCM_ICDR; +#endif + return &SCM_CDR (*al); + } + else + break; + al = &SCM_CDR (*al); + if (SCM_CAR (fl) == var) + { +#ifdef MEMOIZE_LOCALS +#ifndef RECKLESS /* letrec inits to SCM_UNDEFINED */ + if (SCM_UNBNDP (SCM_CAR (*al))) + { + env = SCM_EOL; + goto errout; + } +#endif + SCM_CAR (vloc) = iloc; +#endif + return &SCM_CAR (*al); + } +#ifdef MEMOIZE_LOCALS + iloc += SCM_IDINC; +#endif + } +#ifdef MEMOIZE_LOCALS + iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC); +#endif + } + { + SCM top_thunk, vcell; + if (SCM_NIMP(env)) + { + top_thunk = SCM_CAR(env); /* env now refers to a top level env thunk */ + env = SCM_CDR (env); + } + else + top_thunk = SCM_BOOL_F; + vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F); + if (vcell == SCM_BOOL_F) + goto errout; + else + var = vcell; + } +#ifndef RECKLESS + if (SCM_NNULLP (env) || SCM_UNBNDP (SCM_CDR (var))) + { + var = SCM_CAR (var); + errout: + scm_everr (vloc, genv, var, + (SCM_NULLP (env) + ? "unbound variable: " + : "damaged environment"), + ""); + } +#endif + SCM_CAR (vloc) = var + 1; + /* Except wait...what if the var is not a vcell, + * but syntax or something.... + */ + return &SCM_CDR (var); +} + +#define unmemocar scm_unmemocar +#ifdef __STDC__ +SCM +scm_unmemocar (SCM form, SCM env) +#else +SCM +scm_unmemocar (form, env) + SCM form; + SCM env; +#endif +{ + register int ir; + SCM c; + + if (SCM_IMP (form)) + return form; + c = SCM_CAR (form); + if (1 == (c & 7)) + SCM_CAR (form) = SCM_CAR (c - 1); +#ifdef MEMOIZE_LOCALS + else if (SCM_ILOCP (c)) + { + for (ir = SCM_IFRAME (c); ir != 0; --ir) + env = SCM_CDR (env); + env = SCM_CAR (SCM_CAR (env)); + for (ir = SCM_IDIST (c); ir != 0; --ir) + env = SCM_CDR (env); + SCM_CAR (form) = SCM_ICDRP (c) ? env : SCM_CAR (env); + } +#endif + return form; +} + +#ifdef __STDC__ +SCM +scm_eval_car (SCM pair, SCM env) +#else +SCM +scm_eval_car (pair, env) + SCM pair; + SCM env; +#endif +{ + return EVALCAR (pair, env); +} + + +/* + * The following rewrite expressions and + * some memoized forms have different syntax + */ + +static char s_expression[] = "missing or extra expression"; +static char s_test[] = "bad test"; +static char s_body[] = "bad body"; +static char s_bindings[] = "bad bindings"; +static char s_variable[] = "bad variable"; +static char s_clauses[] = "bad or missing clauses"; +static char s_formals[] = "bad formals"; +#define ASSYNT(_cond, _arg, _pos, _subr) if(!(_cond))scm_wta(_arg, (char *)_pos, _subr); + +SCM scm_i_dot, scm_i_quote, scm_i_quasiquote, scm_i_lambda, scm_i_let, + scm_i_arrow, scm_i_else, scm_i_unquote, scm_i_uq_splicing, scm_i_apply; +SCM scm_i_name; +#ifdef DEBUG_EXTENSIONS +static SCM enter_frame_sym, exit_frame_sym; +#endif +static char s_quasiquote[] = "quasiquote"; +static char s_delay[] = "delay"; + +#define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what); + + +#ifdef __STDC__ +static void +bodycheck (SCM xorig, SCM *bodyloc, char *what) +#else +static void +bodycheck (xorig, bodyloc, what) + SCM xorig; + SCM *bodyloc; + char *what; +#endif +{ + ASRTSYNTAX (scm_ilength (*bodyloc) >= 1, s_expression); +} + + +#ifdef __STDC__ +SCM +scm_m_quote (SCM xorig, SCM env) +#else +SCM +scm_m_quote (xorig, env) + SCM xorig; + SCM env; +#endif +{ + ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "quote"); + return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_begin (SCM xorig, SCM env) +#else +SCM +scm_m_begin (xorig, env) + SCM xorig; + SCM env; +#endif +{ + ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 1, xorig, s_expression, "begin"); + return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_if (SCM xorig, SCM env) +#else +SCM +scm_m_if (xorig, env) + SCM xorig; + SCM env; +#endif +{ + int len = scm_ilength (SCM_CDR (xorig)); + ASSYNT (len >= 2 && len <= 3, xorig, s_expression, "if"); + return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_set (SCM xorig, SCM env) +#else +SCM +scm_m_set (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x; + int len; + + x = SCM_CDR (xorig); + len = scm_ilength (x); + ASSYNT ((len > 0) && !(len & 1), xorig, s_expression, "set!"); + + { + SCM y; + y = x; + while (len) + { + ASSYNT (SCM_NIMP (SCM_CAR (y)) && SCM_SYMBOLP (SCM_CAR (y)), + xorig, s_variable, "set!"); + y = SCM_CDR (SCM_CDR (x)); + len -= 2; + } + } + return scm_cons (SCM_IM_SET, x); +} + + +#if 0 +#ifdef __STDC__ +SCM +scm_m_vref (SCM xorig, SCM env) +#else +SCM +scm_m_vref (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x = SCM_CDR (xorig); + ASSYNT (1 == scm_ilength (x), xorig, s_expression, s_vref); + if (SCM_NIMP(x) && UDSCM_VARIABLEP (SCM_CAR (x))) + { + scm_everr (SCM_UNDEFINED, env, SCM_CAR(SCM_CDR(x)), s_variable, + "global variable reference"); + } + ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)), + xorig, s_variable, s_vref); + return + return scm_cons (IM_VREF, x); +} + + +#ifdef __STDC__ +SCM +scm_m_vset (SCM xorig, SCM env) +#else +SCM +scm_m_vset (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x = SCM_CDR (xorig); + ASSYNT (3 == scm_ilength (x), xorig, s_expression, s_vset); + ASSYNT (( DEFSCM_VARIABLEP (SCM_CAR (x)) + || UDSCM_VARIABLEP (SCM_CAR (x))), + xorig, s_variable, s_vset); + return scm_cons (IM_VSET, x); +} +#endif + + +#ifdef __STDC__ +SCM +scm_m_and (SCM xorig, SCM env) +#else +SCM +scm_m_and (xorig, env) + SCM xorig; + SCM env; +#endif +{ + int len = scm_ilength (SCM_CDR (xorig)); + ASSYNT (len >= 0, xorig, s_test, "and"); + if (len >= 1) + return scm_cons (SCM_IM_AND, SCM_CDR (xorig)); + else + return SCM_BOOL_T; +} + + +#ifdef __STDC__ +SCM +scm_m_or (SCM xorig, SCM env) +#else +SCM +scm_m_or (xorig, env) + SCM xorig; + SCM env; +#endif +{ + int len = scm_ilength (SCM_CDR (xorig)); + ASSYNT (len >= 0, xorig, s_test, "or"); + if (len >= 1) + return scm_cons (SCM_IM_OR, SCM_CDR (xorig)); + else + return SCM_BOOL_F; +} + + +#ifdef __STDC__ +SCM +scm_m_case (SCM xorig, SCM env) +#else +SCM +scm_m_case (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM proc, x = SCM_CDR (xorig); + ASSYNT (scm_ilength (x) >= 2, xorig, s_clauses, "case"); + while (SCM_NIMP (x = SCM_CDR (x))) + { + proc = SCM_CAR (x); + ASSYNT (scm_ilength (proc) >= 2, xorig, s_clauses, "case"); + ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0 || scm_i_else == SCM_CAR (proc), + xorig, s_clauses, "case"); + } + return scm_cons (SCM_IM_CASE, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_cond (SCM xorig, SCM env) +#else +SCM +scm_m_cond (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM arg1, x = SCM_CDR (xorig); + int len = scm_ilength (x); + ASSYNT (len >= 1, xorig, s_clauses, "cond"); + while (SCM_NIMP (x)) + { + arg1 = SCM_CAR (x); + len = scm_ilength (arg1); + ASSYNT (len >= 1, xorig, s_clauses, "cond"); + if (scm_i_else == SCM_CAR (arg1)) + { + ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, xorig, "bad ELSE clause", "cond"); + SCM_CAR (arg1) = SCM_BOOL_T; + } + if (len >= 2 && scm_i_arrow == SCM_CAR (SCM_CDR (arg1))) + ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))), + xorig, "bad recipient", "cond"); + x = SCM_CDR (x); + } + return scm_cons (SCM_IM_COND, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_lambda (SCM xorig, SCM env) +#else +SCM +scm_m_lambda (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM proc, x = SCM_CDR (xorig); + if (scm_ilength (x) < 2) + goto badforms; + proc = SCM_CAR (x); + if SCM_NULLP + (proc) goto memlambda; + if SCM_IMP + (proc) goto badforms; + if SCM_SYMBOLP + (proc) goto memlambda; + if SCM_NCONSP + (proc) goto badforms; + while SCM_NIMP + (proc) + { + if SCM_NCONSP + (proc) + if (!SCM_SYMBOLP (proc)) + goto badforms; + else + goto memlambda; + if (!(SCM_NIMP (SCM_CAR (proc)) && SCM_SYMBOLP (SCM_CAR (proc)))) + goto badforms; + proc = SCM_CDR (proc); + } + if SCM_NNULLP + (proc) + badforms:scm_wta (xorig, s_formals, "lambda"); +memlambda: + bodycheck (xorig, &SCM_CDR (x), "lambda"); + return scm_cons (SCM_IM_LAMBDA, SCM_CDR (xorig)); +} + + +#ifdef __STDC__ +SCM +scm_m_letstar (SCM xorig, SCM env) +#else +SCM +scm_m_letstar (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x = SCM_CDR (xorig), arg1, proc, vars = SCM_EOL, *varloc = &vars; + int len = scm_ilength (x); + ASSYNT (len >= 2, xorig, s_body, "let*"); + proc = SCM_CAR (x); + ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let*"); + while SCM_NIMP + (proc) + { + arg1 = SCM_CAR (proc); + ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let*"); + ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let*"); + *varloc = scm_cons2 (SCM_CAR (arg1), SCM_CAR (SCM_CDR (arg1)), SCM_EOL); + varloc = &SCM_CDR (SCM_CDR (*varloc)); + proc = SCM_CDR (proc); + } + x = scm_cons (vars, SCM_CDR (x)); + bodycheck (xorig, &SCM_CDR (x), "let*"); + return scm_cons (SCM_IM_LETSTAR, x); +} + +/* DO gets the most radically altered syntax + (do ((<var1> <init1> <step1>) + (<var2> <init2>) + ... ) + (<test> <return>) + <body>) + ;; becomes + (do_mem (varn ... var2 var1) + (<init1> <init2> ... <initn>) + (<test> <return>) + (<body>) + <step1> <step2> ... <stepn>) ;; missing steps replaced by var + */ + + +#ifdef __STDC__ +SCM +scm_m_do (SCM xorig, SCM env) +#else +SCM +scm_m_do (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x = SCM_CDR (xorig), arg1, proc; + SCM vars = SCM_EOL, inits = SCM_EOL, steps = SCM_EOL; + SCM *initloc = &inits, *steploc = &steps; + int len = scm_ilength (x); + ASSYNT (len >= 2, xorig, s_test, "do"); + proc = SCM_CAR (x); + ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "do"); + while SCM_NIMP + (proc) + { + arg1 = SCM_CAR (proc); + len = scm_ilength (arg1); + ASSYNT (2 == len || 3 == len, xorig, s_bindings, "do"); + ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "do"); + /* vars reversed here, inits and steps reversed at evaluation */ + vars = scm_cons (SCM_CAR (arg1), vars); /* variable */ + arg1 = SCM_CDR (arg1); + *initloc = scm_cons (SCM_CAR (arg1), SCM_EOL); /* init */ + initloc = &SCM_CDR (*initloc); + arg1 = SCM_CDR (arg1); + *steploc = scm_cons (SCM_IMP (arg1) ? SCM_CAR (vars) : SCM_CAR (arg1), SCM_EOL); /* step */ + steploc = &SCM_CDR (*steploc); + proc = SCM_CDR (proc); + } + x = SCM_CDR (x); + ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, xorig, s_test, "do"); + x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps); + x = scm_cons2 (vars, inits, x); + bodycheck (xorig, &SCM_CAR (SCM_CDR (SCM_CDR (x))), "do"); + return scm_cons (SCM_IM_DO, x); +} + +/* evalcar is small version of inline EVALCAR when we don't care about speed */ +#ifdef __STDC__ +static SCM +evalcar (SCM x, SCM env) +#else +static SCM +evalcar (x, env) + SCM x; + SCM env; +#endif +{ + return XEVALCAR (x, env); +} + +#ifdef __STDC__ +static SCM +iqq (SCM form, SCM env, int depth) +#else +static SCM +iqq (form, env, depth) + SCM form; + SCM env; + int depth; +#endif +{ + SCM tmp; + int edepth = depth; + if SCM_IMP + (form) return form; + if (SCM_VECTORP (form)) + { + long i = SCM_LENGTH (form); + SCM *data = SCM_VELTS (form); + tmp = SCM_EOL; + for (; --i >= 0;) + tmp = scm_cons (data[i], tmp); + return scm_vector (iqq (tmp, env, depth)); + } + if SCM_NCONSP + (form) return form; + tmp = SCM_CAR (form); + if (scm_i_quasiquote == tmp) + { + depth++; + goto label; + } + if (scm_i_unquote == tmp) + { + --depth; + label: + form = SCM_CDR (form); + /* !!! might need a check here to be sure that form isn't a struct. */ + SCM_ASSERT (SCM_NIMP (form) && SCM_ECONSP (form) && SCM_NULLP (SCM_CDR (form)), + form, SCM_ARG1, s_quasiquote); + if (0 == depth) + return evalcar (form, env); + return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL); + } + if (SCM_NIMP (tmp) && (scm_i_uq_splicing == SCM_CAR (tmp))) + { + tmp = SCM_CDR (tmp); + if (0 == --edepth) + return scm_append (scm_cons2 (evalcar (tmp, env), iqq (SCM_CDR (form), env, depth), SCM_EOL)); + } + return scm_cons (iqq (SCM_CAR (form), env, edepth), iqq (SCM_CDR (form), env, depth)); +} + +/* Here are acros which return values rather than code. */ + +#ifdef __STDC__ +SCM +scm_m_quasiquote (SCM xorig, SCM env) +#else +SCM +scm_m_quasiquote (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM x = SCM_CDR (xorig); + ASSYNT (scm_ilength (x) == 1, xorig, s_expression, s_quasiquote); + return iqq (SCM_CAR (x), env, 1); +} + +#ifdef __STDC__ +SCM +scm_m_delay (SCM xorig, SCM env) +#else +SCM +scm_m_delay (xorig, env) + SCM xorig; + SCM env; +#endif +{ + ASSYNT (scm_ilength (xorig) == 2, xorig, s_expression, s_delay); + xorig = SCM_CDR (xorig); + return scm_makprom (scm_closure (scm_cons2 (SCM_EOL, SCM_CAR (xorig), SCM_CDR (xorig)), + env)); +} + +#ifdef __STDC__ +static SCM +env_top_level (SCM env) +#else +static SCM +env_top_level (env) + SCM env; +#endif +{ + while (SCM_NIMP(env)) + { + if (SCM_BOOL_T == scm_procedure_p (SCM_CAR(env))) + return SCM_CAR(env); + env = SCM_CDR (env); + } + return SCM_BOOL_F; +} + +#ifdef __STDC__ +SCM +scm_m_define (SCM x, SCM env) +#else +SCM +scm_m_define (x, env) + SCM x; + SCM env; +#endif +{ + SCM proc, arg1 = x; + x = SCM_CDR (x); + /* ASSYNT(SCM_NULLP(env), x, "bad placement", s_define);*/ + ASSYNT (scm_ilength (x) >= 2, arg1, s_expression, "define"); + proc = SCM_CAR (x); + x = SCM_CDR (x); + while (SCM_NIMP (proc) && SCM_CONSP (proc)) + { /* nested define syntax */ + x = scm_cons (scm_cons2 (scm_i_lambda, SCM_CDR (proc), x), SCM_EOL); + proc = SCM_CAR (proc); + } + ASSYNT (SCM_NIMP (proc) && SCM_SYMBOLP (proc), arg1, s_variable, "define"); + ASSYNT (1 == scm_ilength (x), arg1, s_expression, "define"); + if (SCM_TOP_LEVEL (env)) + { + x = evalcar (x, env); + arg1 = scm_sym2vcell (proc, env_top_level (env), SCM_BOOL_T); +#if 0 +#ifndef RECKLESS + if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == proc) + && (SCM_CDR (arg1) != x)) + scm_warn ("redefining built-in ", SCM_CHARS (proc)); + else +#endif + if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1)) + scm_warn ("redefining ", SCM_CHARS (proc)); +#endif +#ifdef DEBUG_EXTENSIONS + if (RECORD_PROCNAMES && SCM_NIMP (x) && SCM_CLOSUREP (x)) + scm_set_procedure_property_x (x, scm_i_name, proc); +#endif + SCM_CDR (arg1) = x; +#ifdef SICP + return scm_cons2 (scm_i_quote, SCM_CAR (arg1), SCM_EOL); +#else + return SCM_UNSPECIFIED; +#endif + } + return scm_cons2 (SCM_IM_DEFINE, proc, x); +} +/* end of acros */ + +#ifdef __STDC__ +SCM +scm_m_letrec (SCM xorig, SCM env) +#else +SCM +scm_m_letrec (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */ + char *what = SCM_CHARS (SCM_CAR (xorig)); + SCM x = cdrx, proc, arg1; /* structure traversers */ + SCM vars = SCM_EOL, inits = SCM_EOL, *initloc = &inits; + + ASRTSYNTAX (scm_ilength (x) >= 2, s_body); + proc = SCM_CAR (x); + if SCM_NULLP + (proc) return scm_m_letstar (xorig, env); /* null binding, let* faster */ + ASRTSYNTAX (scm_ilength (proc) >= 1, s_bindings); + do + { + /* vars scm_list reversed here, inits reversed at evaluation */ + arg1 = SCM_CAR (proc); + ASRTSYNTAX (2 == scm_ilength (arg1), s_bindings); + ASRTSYNTAX (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), s_variable); + vars = scm_cons (SCM_CAR (arg1), vars); + *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); + initloc = &SCM_CDR (*initloc); + } + while SCM_NIMP + (proc = SCM_CDR (proc)); + cdrx = scm_cons2 (vars, inits, SCM_CDR (x)); + bodycheck (xorig, &SCM_CDR (SCM_CDR (cdrx)), what); + return scm_cons (SCM_IM_LETREC, cdrx); +} + +#ifdef __STDC__ +SCM +scm_m_let (SCM xorig, SCM env) +#else +SCM +scm_m_let (xorig, env) + SCM xorig; + SCM env; +#endif +{ + SCM cdrx = SCM_CDR (xorig); /* locally mutable version of form */ + SCM x = cdrx, proc, arg1, name; /* structure traversers */ + SCM vars = SCM_EOL, inits = SCM_EOL, *varloc = &vars, *initloc = &inits; + + ASSYNT (scm_ilength (x) >= 2, xorig, s_body, "let"); + proc = SCM_CAR (x); + if (SCM_NULLP (proc) + || (SCM_NIMP (proc) && SCM_CONSP (proc) + && SCM_NIMP (SCM_CAR (proc)) && SCM_CONSP (SCM_CAR (proc)) && SCM_NULLP (SCM_CDR (proc)))) + return scm_m_letstar (xorig, env); /* null or single binding, let* is faster */ + ASSYNT (SCM_NIMP (proc), xorig, s_bindings, "let"); + if (SCM_CONSP (proc)) /* plain let, proc is <bindings> */ + return scm_cons (SCM_IM_LET, SCM_CDR (scm_m_letrec (xorig, env))); + if (!SCM_SYMBOLP (proc)) + scm_wta (xorig, s_bindings, "let"); /* bad let */ + name = proc; /* named let, build equiv letrec */ + x = SCM_CDR (x); + ASSYNT (scm_ilength (x) >= 2, xorig, s_body, "let"); + proc = SCM_CAR (x); /* bindings scm_list */ + ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let"); + while SCM_NIMP + (proc) + { /* vars and inits both in order */ + arg1 = SCM_CAR (proc); + ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let"); + ASSYNT (SCM_NIMP (SCM_CAR (arg1)) && SCM_SYMBOLP (SCM_CAR (arg1)), xorig, s_variable, "let"); + *varloc = scm_cons (SCM_CAR (arg1), SCM_EOL); + varloc = &SCM_CDR (*varloc); + *initloc = scm_cons (SCM_CAR (SCM_CDR (arg1)), SCM_EOL); + initloc = &SCM_CDR (*initloc); + proc = SCM_CDR (proc); + } + return + scm_m_letrec (scm_cons2 (scm_i_let, + scm_cons (scm_cons2 (name, scm_cons2 (scm_i_lambda, vars, SCM_CDR (x)), SCM_EOL), SCM_EOL), + scm_acons (name, inits, SCM_EOL)), /* body */ + env); +} + + +#ifdef __STDC__ +SCM +scm_m_apply (SCM xorig, SCM env) +#else +SCM +scm_m_apply (xorig, env) + SCM xorig; + SCM env; +#endif +{ + ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, xorig, s_expression, "@apply"); + return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig)); +} + +#define s_atcall_cc (SCM_ISYMSCM_CHARS(SCM_IM_CONT)+1) + +#ifdef __STDC__ +SCM +scm_m_cont (SCM xorig, SCM env) +#else +SCM +scm_m_cont (xorig, env) + SCM xorig; + SCM env; +#endif +{ + ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, xorig, s_expression, "@call-with-current-continuation"); + return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); +} + +#ifndef RECKLESS +#ifdef __STDC__ +int +scm_badargsp (SCM formals, SCM args) +#else +int +scm_badargsp (formals, args) + SCM formals; + SCM args; +#endif +{ + while SCM_NIMP + (formals) + { + if SCM_NCONSP + (formals) return 0; + if SCM_IMP + (args) return 1; + formals = SCM_CDR (formals); + args = SCM_CDR (args); + } + return SCM_NNULLP (args) ? 1 : 0; +} +#endif + + + +long scm_tc16_macro; + +#endif /* !DEVAL */ + +#ifdef DEVAL +#undef SCM_EVAL_ARGS +#define SCM_EVAL_ARGS scm_deval_args +#undef SCM_CEVAL +#define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */ +#undef SCM_APPLY +#define SCM_APPLY scm_dapply +#undef RETURN +#define RETURN(e) {proc = (e); goto exit;} +#else +#define SCM_EVAL_ARGS scm_eval_args +#define RETURN(x) return x; +#endif + +SCM +SCM_EVAL_ARGS (l, env) + SCM l, env; +{ + SCM res = SCM_EOL, *lloc = &res; + while (SCM_NIMP (l)) + { + *lloc = scm_cons (EVALCAR (l, env), SCM_EOL); + lloc = &SCM_CDR (*lloc); + l = SCM_CDR (l); + } + return res; +} + +#if 0 +#ifdef __STDC__ +SCM +scm_ceval (SCM x, SCM env) +#else +SCM +scm_ceval (x, env) + SCM x; + SCM env; +#endif +{} +#endif +#if 0 +#ifdef __STDC__ +SCM +scm_deval (SCM x, SCM env) +#else +SCM +scm_deval (x, env) + SCM x; + SCM env; +#endif +{} +#endif + +#ifdef SCM_FLOATS +#define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B))))) +#else +#define CHECK_EQVISH(A,B) ((A) == (B)) +#endif + + +SCM +SCM_CEVAL (x, env) + SCM x; + SCM env; +{ + union + { + SCM *lloc; + SCM arg1; + } t; + SCM proc; + SCM arg2; + + SCM_CHECK_STACK; + + loop: + SCM_ASYNC_TICK; + + switch (SCM_TYP7 (x)) + { + case scm_tcs_symbols: + /* Only happens when called at top level. + */ + x = scm_cons (x, SCM_UNDEFINED); + goto retval; + + case (127 & SCM_IM_AND): + x = SCM_CDR (x); + t.arg1 = x; + while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + if (SCM_FALSEP (EVALCAR (x, env))) + { + RETURN (SCM_BOOL_F); + } + else + x = t.arg1; + goto carloop; + + case (127 & SCM_IM_BEGIN): + + cdrxbegin: + x = SCM_CDR (x); + + begin: + t.arg1 = x; + while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + { + SIDEVAL (SCM_CAR (x), env); + x = t.arg1; + } + + carloop: /* scm_eval car of last form in list */ + if (SCM_NCELLP (SCM_CAR (x))) + { + x = SCM_CAR (x); + RETURN (SCM_IMP (x) ? EVALIMP (x, env) : SCM_GLOC_VAL (x)); + } + + if (SCM_SYMBOLP (SCM_CAR (x))) + { + retval: + RETURN (*scm_lookupcar (x, env)); + } + + x = SCM_CAR (x); + goto loop; /* tail recurse */ + + + case (127 & SCM_IM_CASE): + x = SCM_CDR (x); + t.arg1 = EVALCAR (x, env); + while (SCM_NIMP (x = SCM_CDR (x))) + { + proc = SCM_CAR (x); + if (scm_i_else == SCM_CAR (proc)) + { + x = SCM_CDR (proc); + goto begin; + } + proc = SCM_CAR (proc); + while (SCM_NIMP (proc)) + { + if (CHECK_EQVISH (SCM_CAR (proc), t.arg1)) + { + x = SCM_CDR (SCM_CAR (x)); + goto begin; + } + proc = SCM_CDR (proc); + } + } + RETURN (SCM_UNSPECIFIED); + + + case (127 & SCM_IM_COND): + while (SCM_NIMP (x = SCM_CDR (x))) + { + proc = SCM_CAR (x); + t.arg1 = EVALCAR (proc, env); + if (SCM_NFALSEP (t.arg1)) + { + x = SCM_CDR (proc); + if (SCM_NULLP (x)) + { + RETURN (t.arg1); + } + if (scm_i_arrow != SCM_CAR (x)) + goto begin; + proc = SCM_CDR (x); + proc = EVALCAR (proc, env); + SCM_ASRTGO (SCM_NIMP (proc), badfun); + goto evap1; + } + } + RETURN (SCM_UNSPECIFIED); + + + case (127 & SCM_IM_DO): + x = SCM_CDR (x); + proc = SCM_CAR (SCM_CDR (x)); /* inits */ + t.arg1 = SCM_EOL; /* values */ + while (SCM_NIMP (proc)) + { + t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); + proc = SCM_CDR (proc); + } + env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env); + x = SCM_CDR (SCM_CDR (x)); + while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env))) + { + for (proc = SCM_CAR (SCM_CDR (x)); SCM_NIMP (proc); proc = SCM_CDR (proc)) + { + t.arg1 = SCM_CAR (proc); /* body */ + SIDEVAL (t.arg1, env); + } + for (t.arg1 = SCM_EOL, proc = SCM_CDR (SCM_CDR (x)); SCM_NIMP (proc); proc = SCM_CDR (proc)) + t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); /* steps */ + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env)); + } + x = SCM_CDR (proc); + if (SCM_NULLP (x)) + { + RETURN (SCM_UNSPECIFIED); + } + goto begin; + + + case (127 & SCM_IM_IF): + x = SCM_CDR (x); + if (SCM_NFALSEP (EVALCAR (x, env))) + x = SCM_CDR (x); + else if (SCM_IMP (x = SCM_CDR (SCM_CDR (x)))) + { + RETURN (SCM_UNSPECIFIED); + } + goto carloop; + + + case (127 & SCM_IM_LET): + x = SCM_CDR (x); + proc = SCM_CAR (SCM_CDR (x)); + t.arg1 = SCM_EOL; + do + { + t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); + } + while (SCM_NIMP (proc = SCM_CDR (proc))); + env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env); + x = SCM_CDR (x); + goto cdrxbegin; + + + case (127 & SCM_IM_LETREC): + x = SCM_CDR (x); + env = EXTEND_SCM_ENV (SCM_CAR (x), scm_undefineds, env); + x = SCM_CDR (x); + proc = SCM_CAR (x); + t.arg1 = SCM_EOL; + do + { + t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1); + } + while (SCM_NIMP (proc = SCM_CDR (proc))); + SCM_CDR (SCM_CAR (env)) = t.arg1; + goto cdrxbegin; + + + case (127 & SCM_IM_LETSTAR): + x = SCM_CDR (x); + proc = SCM_CAR (x); + if (SCM_IMP (proc)) + { + env = EXTEND_SCM_ENV (SCM_EOL, SCM_EOL, env); + goto cdrxbegin; + } + do + { + t.arg1 = SCM_CAR (proc); + proc = SCM_CDR (proc); + env = EXTEND_SCM_ENV (t.arg1, EVALCAR (proc, env), env); + } + while (SCM_NIMP (proc = SCM_CDR (proc))); + goto cdrxbegin; + + case (127 & SCM_IM_OR): + x = SCM_CDR (x); + t.arg1 = x; + while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + { + x = EVALCAR (x, env); + if (SCM_NFALSEP (x)) + { + RETURN (x); + } + x = t.arg1; + } + goto carloop; + + + case (127 & SCM_IM_LAMBDA): + RETURN (scm_closure (SCM_CDR (x), env)); + + + case (127 & SCM_IM_QUOTE): + RETURN (SCM_CAR (SCM_CDR (x))); + + + case (127 & SCM_IM_SET): + set_some_more: + x = SCM_CDR (x); + proc = SCM_CAR (x); + switch (7 & (int)proc) + { + case 0: + t.lloc = scm_lookupcar (x, env); + break; + case 1: + t.lloc = &SCM_GLOC_VAL (proc); + break; +#ifdef MEMOIZE_LOCALS + case 4: + t.lloc = scm_ilookup (proc, env); + break; +#endif + } + x = SCM_CDR (x); + *t.lloc = EVALCAR (x, env); + if (!SCM_NULLP (SCM_CDR(x))) + goto set_some_more; +#ifdef SICP + RETURN (*t.lloc); +#else + RETURN (SCM_UNSPECIFIED); +#endif + + + case (127 & SCM_IM_DEFINE): /* only for internal defines */ + x = SCM_CDR (x); + proc = SCM_CAR (x); + x = SCM_CDR (x); + x = evalcar (x, env); + env = SCM_CAR (env); + SCM_DEFER_INTS; + SCM_CAR (env) = scm_cons (proc, SCM_CAR (env)); + SCM_CDR (env) = scm_cons (x, SCM_CDR (env)); + SCM_ALLOW_INTS; + RETURN (SCM_UNSPECIFIED); + + + + /* new syntactic forms go here. */ + case (127 & SCM_MAKISYM (0)): + proc = SCM_CAR (x); + SCM_ASRTGO (SCM_ISYMP (proc), badfun); + switch SCM_ISYMNUM (proc) + { +#if 0 + case (SCM_ISYMNUM (IM_VREF)): + { + SCM var; + var = SCM_CAR (SCM_CDR (x)); + RETURN (SCM_CDR(var)); + } + case (SCM_ISYMNUM (IM_VSET)): + SCM_CDR (SCM_CAR ( SCM_CDR (x))) = EVALCAR( SCM_CDR ( SCM_CDR (x)), env); + SCM_CAR (SCM_CAR ( SCM_CDR (x))) = scm_tc16_variable; + RETURN (SCM_UNSPECIFIED); +#endif + + case (SCM_ISYMNUM (SCM_IM_APPLY)): + proc = SCM_CDR (x); + proc = EVALCAR (proc, env); + SCM_ASRTGO (SCM_NIMP (proc), badfun); + if (SCM_CLOSUREP (proc)) + { + t.arg1 = SCM_CDR (SCM_CDR (x)); + t.arg1 = EVALCAR (t.arg1, env); +#ifndef RECKLESS + if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1)) + goto wrongnumargs; +#endif + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), t.arg1, SCM_ENV (proc)); + x = SCM_CODE (proc); + goto cdrxbegin; + } + proc = scm_i_apply; + goto evapply; + + case (SCM_ISYMNUM (SCM_IM_CONT)): + scm_make_cont (&t.arg1); + if (setjmp (SCM_JMPBUF (t.arg1))) + { + SCM val; + val = SCM_THROW_VALUE (t.arg1); + RETURN (val);; + } + proc = SCM_CDR (x); + proc = evalcar (proc, env); + SCM_ASRTGO (SCM_NIMP (proc), badfun); + goto evap1; + + default: + goto badfun; + } + + default: + proc = x; + badfun: + scm_everr (x, env, proc, "Wrong type to apply: ", ""); + + case scm_tc7_vector: + case scm_tc7_wvect: + 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 + case scm_tc7_string: + case scm_tc7_mb_string: + case scm_tc7_substring: + case scm_tc7_mb_substring: + case scm_tc7_smob: + case scm_tcs_closures: + case scm_tcs_subrs: + RETURN (x); + +#ifdef MEMOIZE_LOCALS + case (127 & SCM_ILOC00): + proc = *scm_ilookup (SCM_CAR (x), env); + SCM_ASRTGO (SCM_NIMP (proc), badfun); +#ifndef RECKLESS +#ifdef CAUTIOUS + goto checkargs; +#endif +#endif + break; +#endif /* ifdef MEMOIZE_LOCALS */ + + + case scm_tcs_cons_gloc: + proc = SCM_GLOC_VAL (SCM_CAR (x)); + SCM_ASRTGO (SCM_NIMP (proc), badfun); +#ifndef RECKLESS +#ifdef CAUTIOUS + goto checkargs; +#endif +#endif + break; + + + case scm_tcs_cons_nimcar: + if (SCM_SYMBOLP (SCM_CAR (x))) + { + proc = *scm_lookupcar (x, env); + if (SCM_IMP (proc)) + { + unmemocar (x, env); + goto badfun; + } + if (scm_tc16_macro == SCM_TYP16 (proc)) + { + unmemocar (x, env); + + handle_a_macro: + t.arg1 = SCM_APPLY (SCM_CDR (proc), x, scm_cons (env, scm_listofnull)); + switch ((int) (SCM_CAR (proc) >> 16)) + { + case 2: + if (scm_ilength (t.arg1) <= 0) + t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL); + SCM_DEFER_INTS; + SCM_CAR (x) = SCM_CAR (t.arg1); + SCM_CDR (x) = SCM_CDR (t.arg1); + SCM_ALLOW_INTS; + goto loop; + case 1: + if (SCM_NIMP (x = t.arg1)) + goto loop; + case 0: + RETURN (t.arg1); + } + } + } + else + proc = SCM_CEVAL (SCM_CAR (x), env); + SCM_ASRTGO (SCM_NIMP (proc), badfun); +#ifndef RECKLESS +#ifdef CAUTIOUS + checkargs: +#endif + if (SCM_CLOSUREP (proc)) + { + arg2 = SCM_CAR (SCM_CODE (proc)); + t.arg1 = SCM_CDR (x); + while (SCM_NIMP (arg2)) + { + if (SCM_NCONSP (arg2)) + goto evapply; + if (SCM_IMP (t.arg1)) + goto umwrongnumargs; + arg2 = SCM_CDR (arg2); + t.arg1 = SCM_CDR (t.arg1); + } + if (SCM_NNULLP (t.arg1)) + goto umwrongnumargs; + } + else if (scm_tc16_macro == SCM_TYP16 (proc)) + goto handle_a_macro; +#endif + } + + + evapply: + if (SCM_NULLP (SCM_CDR (x))) + switch (SCM_TYP7 (proc)) + { /* no arguments given */ + case scm_tc7_subr_0: + RETURN (SCM_SUBRF (proc) ()); + case scm_tc7_subr_1o: + RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED)); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (SCM_EOL)); + case scm_tc7_rpsubr: + RETURN (SCM_BOOL_T); + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED)); + case scm_tc7_cclo: + t.arg1 = proc; + proc = SCM_CCLO_SUBR (proc); + goto evap1; + case scm_tcs_closures: + x = SCM_CODE (proc); + env = EXTEND_SCM_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc)); + goto cdrxbegin; + case scm_tc7_contin: + case scm_tc7_subr_1: + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + case scm_tc7_cxr: + case scm_tc7_subr_3: + case scm_tc7_lsubr_2: + umwrongnumargs: + unmemocar (x, env); + wrongnumargs: + scm_everr (x, env, proc, (char *) SCM_WNA, ""); + default: + /* handle macros here */ + goto badfun; + } + + + /* must handle macros by here */ + x = SCM_CDR (x); +#ifdef CAUTIOUS + if (SCM_IMP (x)) + goto wrongnumargs; +#endif + t.arg1 = EVALCAR (x, env); + x = SCM_CDR (x); + if (SCM_NULLP (x)) + { + evap1: + switch (SCM_TYP7 (proc)) + { /* have one argument in t.arg1 */ + case scm_tc7_subr_2o: + RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED)); + case scm_tc7_subr_1: + case scm_tc7_subr_1o: + RETURN (SCM_SUBRF (proc) (t.arg1)); + case scm_tc7_cxr: +#ifdef SCM_FLOATS + if (SCM_SUBRF (proc)) + { + if (SCM_INUMP (t.arg1)) + { + RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1)), + 0.0)); + } + SCM_ASRTGO (SCM_NIMP (t.arg1), floerr); + if (SCM_REALP (t.arg1)) + { + RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (t.arg1)), 0.0)); + } +#ifdef SCM_BIGDIG + if (SCM_BIGP (t.arg1)) + { + RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (t.arg1)), 0.0)); + } +#endif + floerr: + scm_wta (t.arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); + } +#endif + proc = (SCM) SCM_SNAME (proc); + { + char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; + while ('c' != *--chrs) + { + SCM_ASSERT (SCM_NIMP (t.arg1) && SCM_CONSP (t.arg1), + t.arg1, SCM_ARG1, SCM_CHARS (proc)); + t.arg1 = ('a' == *chrs) ? SCM_CAR (t.arg1) : SCM_CDR (t.arg1); + } + RETURN (t.arg1); + } + case scm_tc7_rpsubr: + RETURN (SCM_BOOL_T); + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED)); + case scm_tc7_lsubr: +#ifdef DEVAL + RETURN (SCM_SUBRF (proc) (dbg_info.args)); +#else + RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL))); +#endif + case scm_tc7_cclo: + arg2 = t.arg1; + t.arg1 = proc; + proc = SCM_CCLO_SUBR (proc); + goto evap2; + case scm_tcs_closures: + x = SCM_CODE (proc); +#ifdef DEVAL + env = EXTEND_SCM_ENV (SCM_CAR (x), dbg_info.args, SCM_ENV (proc)); +#else + env = EXTEND_SCM_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc)); +#endif + goto cdrxbegin; + case scm_tc7_contin: + scm_call_continuation (proc, t.arg1); + case scm_tc7_subr_2: + case scm_tc7_subr_0: + case scm_tc7_subr_3: + case scm_tc7_lsubr_2: + goto wrongnumargs; + default: + goto badfun; + } + } +#ifdef CAUTIOUS + if (SCM_IMP (x)) + goto wrongnumargs; +#endif + { /* have two or more arguments */ + arg2 = EVALCAR (x, env); + x = SCM_CDR (x); + if (SCM_NULLP (x)) { +#ifdef CCLO + evap2: +#endif +#ifdef DEVAL + dbg_info.args = scm_cons2 (t.arg1, arg2, SCM_EOL); +#endif + switch SCM_TYP7 + (proc) + { /* have two arguments */ + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + RETURN (SCM_SUBRF (proc) (t.arg1, arg2)); + case scm_tc7_lsubr: +#ifdef DEVAL + RETURN (SCM_SUBRF (proc) (dbg_info.args)); +#else + RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL))); +#endif + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_EOL)); + case scm_tc7_rpsubr: + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (t.arg1, arg2)); +#ifdef CCLO + cclon: case scm_tc7_cclo: + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc, + scm_cons2 (t.arg1, arg2, scm_cons (SCM_EVAL_ARGS (x, env), SCM_EOL)))); + /* case scm_tc7_cclo: + x = scm_cons(arg2, scm_eval_args(x, env)); + arg2 = t.arg1; + t.arg1 = proc; + proc = SCM_CCLO_SUBR(proc); + goto evap3; */ +#endif + case scm_tc7_subr_0: + case scm_tc7_cxr: + case scm_tc7_subr_1o: + case scm_tc7_subr_1: + case scm_tc7_subr_3: + case scm_tc7_contin: + goto wrongnumargs; + default: + goto badfun; + case scm_tcs_closures: +#ifdef DEVAL + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), dbg_info.args, SCM_ENV (proc)); +#else + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc)); +#endif + x = SCM_CODE (proc); + goto cdrxbegin; + } + } +#ifdef DEVAL + dbg_info.args = scm_cons2 (t.arg1, arg2, scm_deval_args (x, env)); +#endif + switch SCM_TYP7 + (proc) + { /* have 3 or more arguments */ +#ifdef DEVAL + case scm_tc7_subr_3: + SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CAR (SCM_CDR (SCM_CDR (dbg_info.args))))); + case scm_tc7_asubr: + /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2); + while SCM_NIMP(x) { + t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env)); + x = SCM_CDR(x); + } + RETURN (t.arg1) */ + case scm_tc7_rpsubr: + RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, SCM_CDR (SCM_CDR (dbg_info.args)), SCM_EOL))); + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (dbg_info.args)))); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (dbg_info.args)); +#ifdef CCLO + case scm_tc7_cclo: + goto cclon; +#endif + case scm_tcs_closures: + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), + dbg_info.args, + SCM_ENV (proc)); + x = SCM_CODE (proc); + goto cdrxbegin; +#else + case scm_tc7_subr_3: + SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, EVALCAR (x, env))); + case scm_tc7_asubr: + /* t.arg1 = SCM_SUBRF(proc)(t.arg1, arg2); + while SCM_NIMP(x) { + t.arg1 = SCM_SUBRF(proc)(t.arg1, EVALCAR(x, env)); + x = SCM_CDR(x); + } + RETURN (t.arg1) */ + case scm_tc7_rpsubr: + RETURN (SCM_APPLY (proc, t.arg1, scm_acons (arg2, scm_eval_args (x, env), SCM_EOL))); + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (t.arg1, arg2, scm_eval_args (x, env))); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)))); +#ifdef CCLO + case scm_tc7_cclo: + goto cclon; +#endif + case scm_tcs_closures: + env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), + scm_cons2 (t.arg1, arg2, scm_eval_args (x, env)), + SCM_ENV (proc)); + x = SCM_CODE (proc); + goto cdrxbegin; +#endif /* DEVAL */ + case scm_tc7_subr_2: + case scm_tc7_subr_1o: + case scm_tc7_subr_2o: + case scm_tc7_subr_0: + case scm_tc7_cxr: + case scm_tc7_subr_1: + case scm_tc7_contin: + goto wrongnumargs; + default: + goto badfun; + } + } +#ifdef DEVAL + exit: + if (CHECK_SCM_EXIT) + { + /* if (SINGLE_STEP) ... but this is always fulfilled. */ + SINGLE_STEP = 0; + scm_make_cont (&t.arg1); + if (setjmp (SCM_JMPBUF (t.arg1))) + { + proc = SCM_THROW_VALUE(t.arg1); + goto ret; + } + scm_ithrow (exit_frame_sym, proc, 0); + } + ret: + last_debug_info_frame = dbg_info.prev; + return proc; +#endif +} + +#ifndef DEVAL + +SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation); +#ifdef __STDC__ +SCM +scm_procedure_documentation (SCM proc) +#else +SCM +scm_procedure_documentation (proc) + SCM proc; +#endif +{ + SCM code; + SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc) && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin, + proc, SCM_ARG1, s_procedure_documentation); + switch (SCM_TYP7 (proc)) + { + case scm_tcs_closures: + code = SCM_CDR (SCM_CODE (proc)); + if (SCM_IMP (SCM_CDR (code))) + return SCM_BOOL_F; + code = SCM_CAR (code); + if (SCM_IMP (code)) + return SCM_BOOL_F; + if (SCM_STRINGP (code)) + return code; + default: + return SCM_BOOL_F; +/* + case scm_tcs_subrs: +#ifdef CCLO + case scm_tc7_cclo: +#endif +*/ + } +} + +/* This code is for scm_apply. it is destructive on multiple args. + * This will only screw you if you do (scm_apply scm_apply '( ... )) + */ +SCM_PROC(s_nconc2last, "apply:nconc2last", 1, 0, 0, scm_nconc2last); +#ifdef __STDC__ +SCM +scm_nconc2last (SCM lst) +#else +SCM +scm_nconc2last (lst) + SCM lst; +#endif +{ + SCM *lloc; + if (SCM_EOL == lst) + return lst; + SCM_ASSERT (SCM_NIMP (lst) && SCM_CONSP (lst), lst, SCM_ARG1, s_nconc2last); + lloc = &lst; + while (SCM_NNULLP (SCM_CDR (*lloc))) + { + lloc = &SCM_CDR (*lloc); + SCM_ASSERT (SCM_NIMP (*lloc) && SCM_CONSP (*lloc), lst, SCM_ARG1, s_nconc2last); + } + *lloc = SCM_CAR (*lloc); + return lst; +} + +#endif /* !DEVAL */ + +#if 0 +#ifdef __STDC__ +SCM +scm_apply (SCM proc, SCM arg1, SCM args) +#else +SCM +scm_apply (proc, arg1, args) + SCM proc; + SCM arg1; + SCM args; +#endif +{} +#endif + +#if 0 +#ifdef __STDC__ +SCM +scm_dapply (SCM proc, SCM arg1, SCM args) +#else +SCM +scm_dapply (proc, arg1, args) + SCM proc; + SCM arg1; + SCM args; +#endif +{} +#endif + + + +#ifdef __STDC__ +SCM +SCM_APPLY (SCM proc, SCM arg1, SCM args) +#else +SCM +SCM_APPLY (proc, arg1, args) + SCM proc; + SCM arg1; + SCM args; +#endif +{ +#ifdef DEBUG_EXTENSIONS +#ifdef DEVAL + debug_info dbg_info; + dbg_info.prev = last_debug_info_frame; + dbg_info.exp = SCM_UNDEFINED; + dbg_info.proc = proc; + dbg_info.args = SCM_UNDEFINED; + last_debug_info_frame = &dbg_info; +#else + if (DEBUGGINGP) + return scm_dapply (proc, arg1, args); +#endif +#endif + + SCM_ASRTGO (SCM_NIMP (proc), badproc); + if (SCM_NULLP (args)) + { + if (SCM_NULLP (arg1)) + arg1 = SCM_UNDEFINED; + else + { + args = SCM_CDR (arg1); + arg1 = SCM_CAR (arg1); + } + } + else + { + /* SCM_ASRTGO(SCM_NIMP(args) && SCM_CONSP(args), wrongnumargs); */ + args = scm_nconc2last (args); + } +#ifdef CCLO + tail: +#endif +#ifdef DEVAL + dbg_info.args = scm_cons (arg1, args); +#endif + switch (SCM_TYP7 (proc)) + { + case scm_tc7_subr_2o: + args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args); + RETURN (SCM_SUBRF (proc) (arg1, args)) + case scm_tc7_subr_2: + SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wrongnumargs); + args = SCM_CAR (args); + RETURN (SCM_SUBRF (proc) (arg1, args)) + case scm_tc7_subr_0: + SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs); + RETURN (SCM_SUBRF (proc) ()) + case scm_tc7_subr_1: + case scm_tc7_subr_1o: + SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); + RETURN (SCM_SUBRF (proc) (arg1)) + case scm_tc7_cxr: + SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); +#ifdef SCM_FLOATS + if (SCM_SUBRF (proc)) + { + if SCM_INUMP + (arg1) + RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0)) + SCM_ASRTGO (SCM_NIMP (arg1), floerr); + if SCM_REALP + (arg1) + RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0)) +#ifdef SCM_BIGDIG + if SCM_BIGP + (arg1) + RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (arg1)), 0.0)) +#endif + floerr: + scm_wta (arg1, (char *) SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); + } +#endif + proc = (SCM) SCM_SNAME (proc); + { + char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; + while ('c' != *--chrs) + { + SCM_ASSERT (SCM_NIMP (arg1) && SCM_CONSP (arg1), + arg1, SCM_ARG1, SCM_CHARS (proc)); + arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); + } + RETURN (arg1) + } + case scm_tc7_subr_3: + RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CAR (SCM_CDR (args)))) + case scm_tc7_lsubr: +#ifdef DEVAL + RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.args)) +#else + RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))) +#endif + case scm_tc7_lsubr_2: + SCM_ASRTGO (SCM_NIMP (args) && SCM_CONSP (args), wrongnumargs); + RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))) + case scm_tc7_asubr: + if (SCM_NULLP (args)) + RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)) + while (SCM_NIMP (args)) + { + SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply"); + arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args)); + args = SCM_CDR (args); + } + RETURN (arg1); + case scm_tc7_rpsubr: + if (SCM_NULLP (args)) + RETURN (SCM_BOOL_T); + while (SCM_NIMP (args)) + { + SCM_ASSERT (SCM_CONSP (args), args, SCM_ARG2, "apply"); + if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, SCM_CAR (args)))) + RETURN (SCM_BOOL_F); + arg1 = SCM_CAR (args); + args = SCM_CDR (args); + } + RETURN (SCM_BOOL_T); + case scm_tcs_closures: +#ifdef DEVAL + arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.args); +#else + arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)); +#endif +#ifndef RECKLESS + if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1)) + goto wrongnumargs; +#endif + args = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), arg1, SCM_ENV (proc)); + proc = SCM_CODE (proc); + while (SCM_NNULLP (proc = SCM_CDR (proc))) + arg1 = EVALCAR (proc, args); + RETURN (arg1); + case scm_tc7_contin: + SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); + scm_call_continuation (proc, arg1); +#ifdef CCLO + case scm_tc7_cclo: +#ifdef DEVAL + args = (SCM_UNBNDP(arg1) ? SCM_EOL : dbg_info.args); +#else + args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); +#endif + arg1 = proc; + proc = SCM_CCLO_SUBR (proc); + goto tail; +#endif + wrongnumargs: + scm_wta (proc, (char *) SCM_WNA, "apply"); + default: + badproc: + scm_wta (proc, (char *) SCM_ARG1, "apply"); + RETURN (arg1); + } +#ifdef DEVAL + exit: + if (CHECK_SCM_EXIT) + { + /* if (SINGLE_STEP) ... but this is always fulfilled. */ + SINGLE_STEP = 0; + scm_make_cont (&arg1); + if (setjmp (SCM_JMPBUF (arg1))) + { + proc = SCM_THROW_VALUE(arg1); + goto ret; + } + scm_ithrow (exit_frame_sym, proc, 0); + } + ret: + last_debug_info_frame = dbg_info.prev; + return proc; +#endif +} + +#ifndef DEVAL + +SCM_PROC(s_map, "map", 2, 0, 1, scm_map); +#ifdef __STDC__ +SCM +scm_map (SCM proc, SCM arg1, SCM args) +#else +SCM +scm_map (proc, arg1, args) + SCM proc; + SCM arg1; + SCM args; +#endif +{ + long i; + SCM res = SCM_EOL; + SCM *pres = &res; + SCM *ve = &args; /* Keep args from being optimized away. */ + + if (SCM_NULLP (arg1)) + return res; + SCM_ASSERT (SCM_NIMP (arg1), arg1, SCM_ARG2, s_map); + if (SCM_NULLP (args)) + { + while (SCM_NIMP (arg1)) + { + SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_map); + *pres = scm_cons (scm_apply (proc, SCM_CAR (arg1), scm_listofnull), SCM_EOL); + pres = &SCM_CDR (*pres); + arg1 = SCM_CDR (arg1); + } + return res; + } + args = scm_vector (scm_cons (arg1, args)); + ve = SCM_VELTS (args); +#ifndef RECKLESS + for (i = SCM_LENGTH (args) - 1; i >= 0; i--) + SCM_ASSERT (SCM_NIMP (ve[i]) && SCM_CONSP (ve[i]), args, SCM_ARG2, s_map); +#endif + while (1) + { + arg1 = SCM_EOL; + for (i = SCM_LENGTH (args) - 1; i >= 0; i--) + { + if SCM_IMP + (ve[i]) return res; + arg1 = scm_cons (SCM_CAR (ve[i]), arg1); + ve[i] = SCM_CDR (ve[i]); + } + *pres = scm_cons (scm_apply (proc, arg1, SCM_EOL), SCM_EOL); + pres = &SCM_CDR (*pres); + } +} + + +SCM_PROC(s_for_each, "for-each", 2, 0, 1, scm_for_each); +#ifdef __STDC__ +SCM +scm_for_each (SCM proc, SCM arg1, SCM args) +#else +SCM +scm_for_each (proc, arg1, args) + SCM proc; + SCM arg1; + SCM args; +#endif +{ + SCM *ve = &args; /* Keep args from being optimized away. */ + long i; + if SCM_NULLP (arg1) + return SCM_UNSPECIFIED; + SCM_ASSERT (SCM_NIMP (arg1), arg1, SCM_ARG2, s_for_each); + if SCM_NULLP (args) + { + while SCM_NIMP (arg1) + { + SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG2, s_for_each); + scm_apply (proc, SCM_CAR (arg1), scm_listofnull); + arg1 = SCM_CDR (arg1); + } + return SCM_UNSPECIFIED; + } + args = scm_vector (scm_cons (arg1, args)); + ve = SCM_VELTS (args); +#ifndef RECKLESS + for (i = SCM_LENGTH (args) - 1; i >= 0; i--) + SCM_ASSERT (SCM_NIMP (ve[i]) && SCM_CONSP (ve[i]), args, SCM_ARG2, s_for_each); +#endif + while (1) + { + arg1 = SCM_EOL; + for (i = SCM_LENGTH (args) - 1; i >= 0; i--) + { + if SCM_IMP + (ve[i]) return SCM_UNSPECIFIED; + arg1 = scm_cons (SCM_CAR (ve[i]), arg1); + ve[i] = SCM_CDR (ve[i]); + } + scm_apply (proc, arg1, SCM_EOL); + } +} + + +#ifdef __STDC__ +SCM +scm_closure (SCM code, SCM env) +#else +SCM +scm_closure (code, env) + SCM code; + SCM env; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_SETCODE (z, code); + SCM_ENV (z) = env; + return z; +} + + +long scm_tc16_promise; +#ifdef __STDC__ +SCM +scm_makprom (SCM code) +#else +SCM +scm_makprom (code) + SCM code; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CDR (z) = code; + SCM_CAR (z) = scm_tc16_promise; + return z; +} + + +#ifdef __STDC__ +static int +prinprom (SCM exp, SCM port, int writing) +#else +static int +prinprom (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + scm_gen_puts (scm_regular_string, "#<promise ", port); + scm_iprin1 (SCM_CDR (exp), port, writing); + scm_gen_putc ('>', port); + return !0; +} + + +SCM_PROC(s_makacro, "procedure->syntax", 1, 0, 0, scm_makacro); +#ifdef __STDC__ +SCM +scm_makacro (SCM code) +#else +SCM +scm_makacro (code) + SCM code; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CDR (z) = code; + SCM_CAR (z) = scm_tc16_macro; + return z; +} + + +SCM_PROC(s_makmacro, "procedure->macro", 1, 0, 0, scm_makmacro); +#ifdef __STDC__ +SCM +scm_makmacro (SCM code) +#else +SCM +scm_makmacro (code) + SCM code; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CDR (z) = code; + SCM_CAR (z) = scm_tc16_macro | (1L << 16); + return z; +} + + +SCM_PROC(s_makmmacro, "procedure->memoizing-macro", 1, 0, 0, scm_makmmacro); +#ifdef __STDC__ +SCM +scm_makmmacro (SCM code) +#else +SCM +scm_makmmacro (code) + SCM code; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CDR (z) = code; + SCM_CAR (z) = scm_tc16_macro | (2L << 16); + return z; +} + + +#ifdef __STDC__ +static int +prinmacro (SCM exp, SCM port, int writing) +#else +static int +prinmacro (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + if (SCM_CAR (exp) & (3L << 16)) + scm_gen_puts (scm_regular_string, "#<macro", port); + else + scm_gen_puts (scm_regular_string, "#<syntax", port); + if (SCM_CAR (exp) & (2L << 16)) + scm_gen_putc ('!', port); + scm_gen_putc (' ', port); + scm_iprin1 (SCM_CDR (exp), port, writing); + scm_gen_putc ('>', port); + return !0; +} + +SCM_PROC(s_force, "force", 1, 0, 0, scm_force); +#ifdef __STDC__ +SCM +scm_force (SCM x) +#else +SCM +scm_force (x) + SCM x; +#endif +{ + SCM_ASSERT ((SCM_TYP16 (x) == scm_tc16_promise), x, SCM_ARG1, s_force); + if (!((1L << 16) & SCM_CAR (x))) + { + SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL); + if (!((1L << 16) & SCM_CAR (x))) + { + SCM_DEFER_INTS; + SCM_CDR (x) = ans; + SCM_CAR (x) |= (1L << 16); + SCM_ALLOW_INTS; + } + } + return SCM_CDR (x); +} + +SCM_PROC (s_promise_p, "promise?", 1, 0, 0, scm_promise_p); +#ifdef __STDC__ +SCM +scm_promise_p (SCM x) +#else +SCM +scm_promise_p (x) + SCM x; +#endif +{ + return ((SCM_NIMP (x) && (SCM_TYP16 (x) == scm_tc16_promise)) + ? SCM_BOOL_T + : SCM_BOOL_F); +} + +SCM_PROC(s_copy_tree, "copy-tree", 1, 0, 0, scm_copy_tree); +#ifdef __STDC__ +SCM +scm_copy_tree (SCM obj) +#else +SCM +scm_copy_tree (obj) + SCM obj; +#endif +{ + SCM ans, tl; + if SCM_IMP + (obj) return obj; + if (SCM_VECTORP (obj)) + { + scm_sizet i = SCM_LENGTH (obj); + ans = scm_make_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED, SCM_UNDEFINED); + while (i--) + SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]); + return ans; + } + if SCM_NCONSP (obj) + return obj; +/* return scm_cons(scm_copy_tree(SCM_CAR(obj)), scm_copy_tree(SCM_CDR(obj))); */ + ans = tl = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED); + while (SCM_NIMP (obj = SCM_CDR (obj)) && SCM_CONSP (obj)) + tl = (SCM_CDR (tl) = scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED)); + SCM_CDR (tl) = obj; + return ans; +} + +#ifdef __STDC__ +SCM +scm_eval_3 (SCM obj, int copyp, SCM env) +#else +SCM +scm_eval_3 (obj, copyp, env) + SCM obj; + int copyp; + SCM env; +#endif +{ + if (SCM_NIMP (SCM_CDR (scm_system_transformer))) + obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull); + else if (copyp) + obj = scm_copy_tree (obj); + return EVAL (obj, env); +} + +#ifdef __STDC__ +SCM +scm_top_level_env (SCM thunk) +#else +SCM +scm_top_level_env (thunk) + SCM thunk; +#endif +{ + if (SCM_IMP(thunk)) + return SCM_EOL; + else + return scm_cons(thunk, (SCM)SCM_EOL); +} + +SCM_PROC(s_eval2, "eval2", 2, 0, 0, scm_eval2); +#ifdef __STDC__ +SCM +scm_eval2 (SCM obj, SCM env_thunk) +#else +SCM +scm_eval2 (obj, env_thunk) + SCM obj; + SCM env_thunk; +#endif +{ + return scm_eval_3 (obj, 1, scm_top_level_env(env_thunk)); +} + +SCM_PROC(s_eval, "eval", 1, 0, 0, scm_eval); +#ifdef __STDC__ +SCM +scm_eval (SCM obj) +#else +SCM +scm_eval (obj) + SCM obj; +#endif +{ + return + scm_eval_3(obj, 1, scm_top_level_env(SCM_CDR(scm_top_level_lookup_thunk_var))); +} + +SCM_PROC(s_eval_x, "eval!", 1, 0, 0, scm_eval_x); +#ifdef __STDC__ +SCM +scm_eval_x (SCM obj) +#else +SCM +scm_eval_x (obj) + SCM obj; +#endif +{ + return + scm_eval_3(obj, + 0, + scm_top_level_env (SCM_CDR (scm_top_level_lookup_thunk_var))); +} + +SCM_PROC (s_macro_eval_x, "macro-eval!", 2, 0, 0, scm_macro_eval_x); +#ifdef __STDC__ +SCM +scm_macro_eval_x (SCM exp, SCM env) +#else +SCM +scm_macro_eval_x (exp, env) + SCM exp; + SCM env; +#endif +{ + return scm_eval_3 (exp, 0, env); +} + +#ifdef __STDC__ +SCM +scm_definedp (SCM x, SCM env) +#else +SCM +scm_definedp (x, env) + SCM x; + SCM env; +#endif +{ + SCM proc = SCM_CAR (x = SCM_CDR (x)); + if (SCM_ISYMP (proc)) + return SCM_BOOL_T; + else if(SCM_IMP(proc) || !SCM_SYMBOLP(proc)) + return SCM_BOOL_F; + else + { + SCM vcell = scm_sym2vcell(proc, env_top_level(env), SCM_BOOL_F); + return (vcell == SCM_BOOL_F || SCM_UNBNDP(SCM_CDR(vcell))) ? SCM_BOOL_F : SCM_BOOL_T; + } +} + +static scm_smobfuns promsmob = +{scm_markcdr, scm_free0, prinprom}; + +static scm_smobfuns macrosmob = +{scm_markcdr, scm_free0, prinmacro}; + +#ifdef __STDC__ +SCM +scm_make_synt (char *name, SCM (*macroizer) (), SCM (*fcn) ()) +#else +SCM +scm_make_synt (name, macroizer, fcn) + char *name; + SCM (*macroizer) (); + SCM (*fcn) (); +#endif +{ + SCM symcell = scm_sysintern (name, SCM_UNDEFINED); + long tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8); + register SCM z; + if ((tmp >> 8) != ((SCM_CELLPTR) (SCM_CAR (symcell)) - scm_heap_org)) + tmp = 0; + SCM_NEWCELL (z); + SCM_SUBRF (z) = fcn; + SCM_CAR (z) = tmp + scm_tc7_subr_2; + SCM_CDR (symcell) = macroizer (z); + return SCM_CAR (symcell); +} + +#ifdef DEBUG_EXTENSIONS +# ifndef DEVAL +# define DEVAL +# include "eval.c" +# endif +#endif + + +#ifdef __STDC__ +void +scm_init_eval (void) +#else +void +scm_init_eval () +#endif +{ +#ifdef DEBUG_EXTENSIONS + enter_frame_sym = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED)); + exit_frame_sym = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED)); +#endif + scm_tc16_promise = scm_newsmob (&promsmob); + scm_tc16_macro = scm_newsmob (¯osmob); + scm_i_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply); + scm_system_transformer = scm_sysintern ("scm:eval-transformer", SCM_UNDEFINED); + scm_i_dot = SCM_CAR (scm_sysintern (".", SCM_UNDEFINED)); + scm_i_arrow = SCM_CAR (scm_sysintern ("=>", SCM_UNDEFINED)); + scm_i_else = SCM_CAR (scm_sysintern ("else", SCM_UNDEFINED)); + scm_i_unquote = SCM_CAR (scm_sysintern ("unquote", SCM_UNDEFINED)); + scm_i_uq_splicing = SCM_CAR (scm_sysintern ("unquote-splicing", SCM_UNDEFINED)); + + /* acros */ + scm_i_quasiquote = scm_make_synt (s_quasiquote, scm_makacro, scm_m_quasiquote); + scm_make_synt ("define", scm_makmmacro, scm_m_define); + scm_make_synt (s_delay, scm_makacro, scm_m_delay); + /* end of acros */ + + scm_top_level_lookup_thunk_var = + scm_sysintern("*top-level-lookup-thunk*", SCM_BOOL_F); + + scm_make_synt ("and", scm_makmmacro, scm_m_and); + scm_make_synt ("begin", scm_makmmacro, scm_m_begin); + scm_make_synt ("case", scm_makmmacro, scm_m_case); + scm_make_synt ("cond", scm_makmmacro, scm_m_cond); + scm_make_synt ("do", scm_makmmacro, scm_m_do); + scm_make_synt ("if", scm_makmmacro, scm_m_if); + scm_i_lambda = scm_make_synt ("lambda", scm_makmmacro, scm_m_lambda); + scm_i_let = scm_make_synt ("let", scm_makmmacro, scm_m_let); + scm_make_synt ("letrec", scm_makmmacro, scm_m_letrec); + scm_make_synt ("let*", scm_makmmacro, scm_m_letstar); + scm_make_synt ("or", scm_makmmacro, scm_m_or); + scm_i_quote = scm_make_synt ("quote", scm_makmmacro, scm_m_quote); + scm_make_synt ("set!", scm_makmmacro, scm_m_set); + scm_make_synt ("@apply", scm_makmmacro, scm_m_apply); + scm_make_synt ("@call-with-current-continuation", scm_makmmacro, scm_m_cont); + scm_make_synt ("defined?", scm_makmmacro, scm_definedp); + scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED)); + scm_permanent_object (scm_i_name); +#include "eval.x" +} +#endif /* !DEVAL */ + diff --git a/libguile/eval.h b/libguile/eval.h new file mode 100644 index 000000000..fb8c0c9ec --- /dev/null +++ b/libguile/eval.h @@ -0,0 +1,218 @@ +/* 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 "__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 */ +#ifdef DEBUG_EXTENSIONS +#define EVAL(x, env) (SCM_IMP(x) \ + ? (x) \ + : (*scm_ceval_ptr) ((x), (env))) +#else +#define EVAL(x, env) (SCM_IMP(x)?(x):scm_ceval((x), (env))) +#endif /* DEBUG_EXTENSIONS */ + +#define SCM_CEVAL scm_ceval +#define SCM_APPLY scm_apply +#define SIDEVAL(x, env) if SCM_NIMP(x) SCM_CEVAL((x), (env)) + + + +#define SCM_EXTEND_SCM_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; +extern SCM scm_top_level_lookup_thunk_var; +extern SCM scm_i_name; + + +/* 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)) + + +#ifdef __STDC__ +extern SCM * scm_ilookup (SCM iloc, SCM env); +extern SCM * scm_lookupcar (SCM vloc, SCM genv); +extern SCM scm_unmemocar (SCM form, SCM env); +extern SCM scm_eval_car (SCM pair, SCM env); +extern SCM scm_m_quote (SCM xorig, SCM env); +extern SCM scm_m_begin (SCM xorig, SCM env); +extern SCM scm_m_if (SCM xorig, SCM env); +extern SCM scm_m_set (SCM xorig, SCM env); +extern SCM scm_m_vref (SCM xorig, SCM env); +extern SCM scm_m_vset (SCM xorig, SCM env); +extern SCM scm_m_and (SCM xorig, SCM env); +extern SCM scm_m_or (SCM xorig, SCM env); +extern SCM scm_m_case (SCM xorig, SCM env); +extern SCM scm_m_cond (SCM xorig, SCM env); +extern SCM scm_m_lambda (SCM xorig, SCM env); +extern SCM scm_m_letstar (SCM xorig, SCM env); +extern SCM scm_m_do (SCM xorig, SCM env); +extern SCM scm_m_quasiquote (SCM xorig, SCM env); +extern SCM scm_m_delay (SCM xorig, SCM env); +extern SCM scm_m_define (SCM x, SCM env); +extern SCM scm_m_letrec (SCM xorig, SCM env); +extern SCM scm_m_let (SCM xorig, SCM env); +extern SCM scm_m_apply (SCM xorig, SCM env); +extern SCM scm_m_cont (SCM xorig, SCM env); +extern int scm_badargsp (SCM formals, SCM args); +extern SCM scm_ceval (SCM x, SCM env); +extern SCM scm_deval (SCM x, SCM env); +extern SCM scm_procedure_documentation (SCM proc); +extern SCM scm_nconc2last (SCM lst); +extern SCM scm_apply (SCM proc, SCM arg1, SCM args); +extern SCM scm_dapply (SCM proc, SCM arg1, SCM args); +extern SCM SCM_APPLY (SCM proc, SCM arg1, SCM args); +extern SCM scm_map (SCM proc, SCM arg1, SCM args); +extern SCM scm_for_each (SCM proc, SCM arg1, SCM args); +extern SCM scm_closure (SCM code, SCM env); +extern SCM scm_makprom (SCM code); +extern SCM scm_makacro (SCM code); +extern SCM scm_makmacro (SCM code); +extern SCM scm_makmmacro (SCM code); +extern SCM scm_force (SCM x); +extern SCM scm_promise_p (SCM x); +extern SCM scm_copy_tree (SCM obj); +extern SCM scm_eval_3 (SCM obj, int copyp, SCM env); +extern SCM scm_top_level_env (SCM thunk); +extern SCM scm_eval2 (SCM obj, SCM env_thunk); +extern SCM scm_eval (SCM obj); +extern SCM scm_eval_x (SCM obj); +extern SCM scm_macro_eval_x (SCM exp, SCM env); +extern SCM scm_definedp (SCM x, SCM env); +extern SCM scm_make_synt (char *name, SCM (*macroizer) (), SCM (*fcn) ()); +extern void scm_init_eval (void); + +#else /* STDC */ +extern SCM * scm_ilookup (); +extern SCM * scm_lookupcar (); +extern SCM scm_unmemocar (); +extern SCM scm_eval_car (); +extern SCM scm_m_quote (); +extern SCM scm_m_begin (); +extern SCM scm_m_if (); +extern SCM scm_m_set (); +extern SCM scm_m_vref (); +extern SCM scm_m_vset (); +extern SCM scm_m_and (); +extern SCM scm_m_or (); +extern SCM scm_m_case (); +extern SCM scm_m_cond (); +extern SCM scm_m_lambda (); +extern SCM scm_m_letstar (); +extern SCM scm_m_do (); +extern SCM scm_m_quasiquote (); +extern SCM scm_m_delay (); +extern SCM scm_m_define (); +extern SCM scm_m_letrec (); +extern SCM scm_m_let (); +extern SCM scm_m_apply (); +extern SCM scm_m_cont (); +extern int scm_badargsp (); +extern SCM scm_ceval (); +extern SCM scm_deval (); +extern SCM scm_procedure_documentation (); +extern SCM scm_nconc2last (); +extern SCM scm_apply (); +extern SCM scm_dapply (); +extern SCM SCM_APPLY (); +extern SCM scm_map (); +extern SCM scm_for_each (); +extern SCM scm_closure (); +extern SCM scm_makprom (); +extern SCM scm_makacro (); +extern SCM scm_makmacro (); +extern SCM scm_makmmacro (); +extern SCM scm_force (); +extern SCM scm_promise_p (); +extern SCM scm_copy_tree (); +extern SCM scm_eval_3 (); +extern SCM scm_top_level_env (); +extern SCM scm_eval2 (); +extern SCM scm_eval (); +extern SCM scm_eval_x (); +extern SCM scm_macro_eval_x (); +extern SCM scm_definedp (); +extern SCM scm_make_synt (); +extern void scm_init_eval (); + +#endif /* STDC */ + +#endif /* EVALH */ diff --git a/libguile/extchrs.c b/libguile/extchrs.c new file mode 100644 index 000000000..44d9a14a1 --- /dev/null +++ b/libguile/extchrs.c @@ -0,0 +1,146 @@ +/* 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 FAKE_EXT_SCM_CHARS + +#ifdef __STDC__ +int +xmblen (const char * str, size_t size) +#else +int +xmblen (str, size) + const char * str; + size_t size; +#endif +{ + if (!str) + return 0; + + if (*(unsigned char *)str > 127) + return ((size < 4) + ? -1 + : 4); + else if (!*str) + return 0; + else + return 1; +} + +#ifdef __STDC__ +int +xwctomb (char * _str, int c) +#else +int +xwctomb (_str, c) + char * _str; + int c; +#endif +{ + 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; +} + +#ifdef __STDC__ +int +xmbtowc (xwchar_t * result, const unsigned char * _str, size_t size) +#else +int +xmbtowc (result, str, size) + xwchar_t * result; + const unsigned char * _str; + size_t size; +#endif +{ + 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 /* FAKE_EXT_SCM_CHARS */ + diff --git a/libguile/extchrs.h b/libguile/extchrs.h new file mode 100644 index 000000000..8d17c4681 --- /dev/null +++ b/libguile/extchrs.h @@ -0,0 +1,83 @@ +/* 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> + +#define FAKE_EXT_SCM_CHARS 1 + +#if !defined(FAKE_EXT_SCM_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 + + + +#ifdef __STDC__ +extern int xmblen (const char * str, size_t size); +extern int xwctomb (char * _str, int c); +extern int xmbtowc (xwchar_t * result, const unsigned char * _str, size_t size); + +#else /* STDC */ +extern int xmblen (); +extern int xwctomb (); +extern int xmbtowc (); + +#endif /* STDC */ + + + + +#endif /* EXTCHRSH */ diff --git a/libguile/feature.c b/libguile/feature.c new file mode 100644 index 000000000..b4622b7e9 --- /dev/null +++ b/libguile/feature.c @@ -0,0 +1,135 @@ +/* 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" + + + +SCM *scm_loc_features; + +#ifdef __STDC__ +void +scm_add_feature(char* str) +#else +void +scm_add_feature(str) + char* str; +#endif +{ + *scm_loc_features = scm_cons(SCM_CAR(scm_intern(str, strlen(str))), *scm_loc_features); +} + + + +/* {Help finding slib} + */ + + +SCM_PROC(s_compiled_library_path, "compiled-library-path", 0, 0, 0, scm_compiled_library_path); +#ifdef __STDC__ +SCM +scm_compiled_library_path (void) +#else +SCM +scm_compiled_library_path () +#endif +{ +#ifndef LIBRARY_PATH + return SCM_BOOL_F; +#else + return scm_makfrom0str (LIBRARY_PATH); +#endif +} + + + + +SCM_PROC(s_program_arguments, "program-arguments", 0, 0, 0, scm_program_arguments); +#ifdef __STDC__ +SCM +scm_program_arguments (void) +#else +SCM +scm_program_arguments () +#endif +{ + return scm_progargs; +} + + + + + + +#ifdef __STDC__ +void +scm_init_feature(void) +#else +void +scm_init_feature() +#endif +{ + scm_loc_features = &SCM_CDR(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 + + + scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_SCM_CODE_LIMIT)); +#include "feature.x" +} diff --git a/libguile/feature.h b/libguile/feature.h new file mode 100644 index 000000000..c1f7b1cb8 --- /dev/null +++ b/libguile/feature.h @@ -0,0 +1,69 @@ +/* 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 "__scm.h" + + + +extern SCM *scm_loc_features; + + +#ifdef __STDC__ +extern void scm_add_feature(char* str); +extern SCM scm_compiled_library_path (void); +extern SCM scm_program_arguments (void); +extern void scm_init_feature(void); + +#else /* STDC */ +extern void scm_add_feature(); +extern SCM scm_compiled_library_path (); +extern SCM scm_program_arguments (); +extern void scm_init_feature(); + +#endif /* STDC */ + + +#endif /* FEATUREH */ diff --git a/libguile/filesys.c b/libguile/filesys.c new file mode 100644 index 000000000..5ca9b309c --- /dev/null +++ b/libguile/filesys.c @@ -0,0 +1,1278 @@ +/* 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" + + +#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 HAVE_SYS_SELECT_H +#include <sys/select.h> +#endif + +#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); +#ifdef __STDC__ +SCM +scm_sys_chown (SCM path, SCM owner, SCM group) +#else +SCM +scm_sys_chown (path, owner, group) + SCM path; + SCM owner; + SCM group; +#endif +{ + 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))); + return val ? SCM_MAKINUM (errno) : SCM_BOOL_T; +} + + +SCM_PROC (s_sys_chmod, "%chmod", 2, 0, 0, scm_sys_chmod); +#ifdef __STDC__ +SCM +scm_sys_chmod (SCM port_or_path, SCM mode) +#else +SCM +scm_sys_chmod (port_or_path, mode) + SCM port_or_path; + SCM mode; +#endif +{ + 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))); + } + return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; +} + +SCM_PROC (s_umask, "umask", 0, 1, 0, scm_umask); +#ifdef __STDC__ +SCM +scm_umask (SCM mode) +#else +SCM +scm_umask (mode) + SCM mode; +#endif +{ + 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; + +#ifdef __STDC__ +static int +scm_fd_print (SCM sexp, SCM port, int writing) +#else +static int +scm_fd_print (sexp, port, writing) + SCM sexp; + SCM port; + int writing; +#endif +{ + scm_gen_puts (scm_regular_string, "#<fd ", port); + scm_intprint (SCM_CDR (sexp), 10, port); + scm_gen_puts (scm_regular_string, ">", port); + return 1; +} + +#ifdef __STDC__ +static scm_sizet +scm_fd_free (SCM p) +#else +static scm_sizet +scm_fd_free (p) + SCM p; +#endif +{ + 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}; + +#ifdef __STDC__ +SCM +scm_intern_fd (int fd, int flags) +#else +SCM +scm_intern_fd (fd, flags) + int fd; + int flags; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_sys_open (SCM path, SCM flags, SCM mode) +#else +SCM +scm_sys_open (path, flags, mode) + SCM path; + SCM flags; + SCM mode; +#endif +{ + 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) + sfd = SCM_MAKINUM (errno); + else + 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); +#ifdef __STDC__ +SCM +scm_sys_create (SCM path, SCM mode) +#else +SCM +scm_sys_create (path, mode) + SCM path; + SCM mode; +#endif +{ + 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) + sfd = SCM_MAKINUM (errno); + else + 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); +#ifdef __STDC__ +SCM +scm_sys_close (SCM sfd) +#else +SCM +scm_sys_close (sfd) + SCM sfd; +#endif +{ + 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; + return (got == -1 ? SCM_MAKINUM (errno) : SCM_BOOL_T); +} + + +SCM_PROC (s_sys_write_fd, "%write-fd", 2, 0, 0, scm_sys_write_fd); +#ifdef __STDC__ +SCM +scm_sys_write_fd (SCM sfd, SCM buf) +#else +SCM +scm_sys_write_fd (sfd, buf) + SCM sfd; + SCM buf; +#endif +{ + 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) + answer = scm_cons (SCM_MAKINUM (errno), SCM_EOL); + else + 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); +#ifdef __STDC__ +SCM +scm_sys_read_fd (SCM sfd, SCM buf, SCM offset, SCM length) +#else +SCM +scm_sys_read_fd (sfd, buf, offset, length) + SCM sfd; + SCM buf; + SCM offset; + SCM length; +#endif +{ + 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) + answer = scm_cons (SCM_MAKINUM (errno), SCM_EOL); + else + 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); +#ifdef __STDC__ +SCM +scm_sys_lseek (SCM sfd, SCM offset, SCM whence) +#else +SCM +scm_sys_lseek (sfd, offset, whence) + SCM sfd; + SCM offset; + SCM whence; +#endif +{ + 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) + answer = SCM_MAKINUM (errno); + else + answer = scm_long2num (got); + SCM_ALLOW_INTS; + return answer; +} + + +SCM_PROC (s_sys_dup, "%dup", 1, 1, 0, scm_sys_dup); +#ifdef __STDC__ +SCM +scm_sys_dup (SCM oldfd, SCM newfd) +#else +SCM +scm_sys_dup (oldfd, newfd) + SCM oldfd; + SCM newfd; +#endif +{ + 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); + answer = (nfd == -1 + ? scm_cons (SCM_MAKINUM (errno), SCM_EOL) + : SCM_MAKINUM (nfd)); + SCM_ALLOW_INTS; + return answer; +} + + + +/* {Files} + */ +#ifdef __STDC__ +static SCM +scm_stat2scm (struct stat *stat_temp) +#else +static SCM +scm_stat2scm (stat_temp) + struct stat *stat_temp; +#endif +{ + SCM ans = scm_make_vector (SCM_MAKINUM (13), 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 + + return ans; +} + +SCM_PROC (s_sys_stat, "%stat", 1, 0, 0, scm_sys_stat); +#ifdef __STDC__ +SCM +scm_sys_stat (SCM fd_or_path) +#else +SCM +scm_sys_stat (fd_or_path) + SCM fd_or_path; +#endif +{ + int rv; + struct stat stat_temp; + + if (SCM_INUMP (fd_or_path)) + { + SCM_ASSERT (SCM_OPFPORTP (fd_or_path), fd_or_path, SCM_ARG1, s_sys_stat); + 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)); + } + + } + return rv ? SCM_MAKINUM (errno) : scm_stat2scm (&stat_temp); +} + + + +/* {Modifying Directories} + */ + +SCM_PROC (s_sys_link, "%link", 2, 0, 0, scm_sys_link); +#ifdef __STDC__ +SCM +scm_sys_link (SCM oldpath, SCM newpath) +#else +SCM +scm_sys_link (oldpath, newpath) + SCM oldpath; + SCM newpath; +#endif +{ + 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))); + return val ? SCM_MAKINUM (errno) : SCM_BOOL_T; +} + + + +SCM_PROC (s_sys_rename, "%rename-file", 2, 0, 0, scm_sys_rename); +#ifdef __STDC__ +SCM +scm_sys_rename (SCM oldname, SCM newname) +#else +SCM +scm_sys_rename (oldname, newname) + SCM oldname; + SCM newname; +#endif +{ + 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))); + return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; +#else + SCM_DEFER_INTS; + SCM_SYSCALL (rv = link (SCM_CHARS (oldname), SCM_CHARS (newname))); + if (!rv) + { + SCM_SYSCALL (rv = unlink (SCM_CHARS (oldname)));; + if (rv) + /* unlink failed. remove new name */ + SCM_SYSCALL (unlink (SCM_CHARS (newname))); + } + SCM_ALLOW_INTS; + return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; +#endif +} + + + +SCM_PROC (s_sys_mkdir, "%mkdir", 1, 1, 0, scm_sys_mkdir); +#ifdef __STDC__ +SCM +scm_sys_mkdir (SCM path, SCM mode) +#else +SCM +scm_sys_mkdir (path, mode) + SCM path; + SCM mode; +#endif +{ +#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))); + } + return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; +#else + return SCM_MAKINUM (ENOSYS); +#endif +} + + +SCM_PROC (s_sys_rmdir, "%rmdir", 1, 0, 0, scm_sys_rmdir); +#ifdef __STDC__ +SCM +scm_sys_rmdir (SCM path) +#else +SCM +scm_sys_rmdir (path) + SCM path; +#endif +{ +#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))); + return val ? SCM_MAKINUM (errno) : SCM_BOOL_T; +#else + return SCM_MAKINUM (ENOSYS); +#endif +} + + +/* {Examining Directories} + */ + +long scm_tc16_dir; + +SCM_PROC (s_sys_opendir, "%opendir", 1, 0, 0, scm_sys_opendir); +#ifdef __STDC__ +SCM +scm_sys_opendir (SCM dirname) +#else +SCM +scm_sys_opendir (dirname) + SCM dirname; +#endif +{ + 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) + { + SCM_ALLOW_INTS; + return SCM_MAKINUM (errno); + } + SCM_CAR (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); +#ifdef __STDC__ +SCM +scm_sys_readdir (SCM port) +#else +SCM +scm_sys_readdir (port) + SCM port; +#endif +{ + 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; + return (rdent + ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0) + : (errno ? SCM_MAKINUM (errno) : SCM_EOF_VAL)); +} + + + +SCM_PROC (s_rewinddir, "rewinddir", 1, 0, 0, scm_rewinddir); +#ifdef __STDC__ +SCM +scm_rewinddir (SCM port) +#else +SCM +scm_rewinddir (port) + SCM port; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_sys_closedir (SCM port) +#else +SCM +scm_sys_closedir (port) + SCM port; +#endif +{ + 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_MAKINUM (errno); + } + SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port))); + if (sts) + { + SCM_ALLOW_INTS; + return SCM_MAKINUM (errno); + } + SCM_CAR (port) = scm_tc16_dir; + SCM_ALLOW_INTS; + return SCM_BOOL_T; +} + + + +#ifdef __STDC__ +static int +scm_dir_print (SCM sexp, SCM port, int writing) +#else +static int +scm_dir_print (sexp, port, writing) + SCM sexp; + SCM port; + int writing; +#endif +{ + scm_prinport (sexp, port, "directory"); + return 1; +} + +#ifdef __STDC__ +static scm_sizet +scm_dir_free (SCM p) +#else +static scm_sizet +scm_dir_free (p) + SCM p; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_sys_chdir (SCM str) +#else +SCM +scm_sys_chdir (str) + SCM str; +#endif +{ + int ans; + SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_chdir); + SCM_SYSCALL (ans = chdir (SCM_CHARS (str))); + return ans ? SCM_MAKINUM (errno) : SCM_BOOL_T; +} + + + +SCM_PROC (s_sys_getcwd, "%getcwd", 0, 0, 0, scm_sys_getcwd); +#ifdef __STDC__ +SCM +scm_sys_getcwd (void) +#else +SCM +scm_sys_getcwd () +#endif +{ +#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) + result = scm_makfromstr (wd, strlen (wd), 0); + else + result = SCM_MAKINUM (errno); + scm_must_free (wd); + SCM_ALLOW_INTS; + return result; +#else + return SCM_MAKINUM (ENOSYS); +#endif +} + + + +#ifdef __STDC__ +static void +fill_select_type (SELECT_TYPE * set, SCM list) +#else +static void +fill_select_type (set, list) + SELECT_TYPE * set; + SCM list; +#endif +{ + 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); + } +} + +#ifdef __STDC__ +static SCM +retrieve_select_type (SELECT_TYPE * set, SCM list) +#else +static SCM +retrieve_select_type (set, list) + SELECT_TYPE * set; + SCM list; +#endif +{ + 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; +} + + +SCM_PROC (s_sys_select, "%select", 3, 2, 0, scm_sys_select); +#ifdef __STDC__ +SCM +scm_sys_select (SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs) +#else +SCM +scm_sys_select (reads, writes, excepts, secs, msecs) + SCM reads; + SCM writes; + SCM excepts; + SCM secs; + SCM msecs; +#endif +{ +#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); + SCM_ALLOW_INTS; + if (sreturn < 0) + return SCM_MAKINUM (errno); + else + return scm_listify (retrieve_select_type (&read_set, reads), + retrieve_select_type (&write_set, writes), + retrieve_select_type (&except_set, excepts), + SCM_UNDEFINED); +#else + return SCM_MAKINUM (ENOSYS); +#endif +} + + +/* {Symbolic Links} + */ + +SCM_PROC (s_sys_symlink, "%symlink", 2, 0, 0, scm_sys_symlink); +#ifdef __STDC__ +SCM +scm_sys_symlink(SCM oldpath, SCM newpath) +#else +SCM +scm_sys_symlink(oldpath, newpath) + SCM oldpath; + SCM newpath; +#endif +{ +#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))); + return val ? SCM_MAKINUM (errno) : SCM_BOOL_T; +#else + return SCM_MAKINUM (ENOSYS); +#endif +} + + +SCM_PROC (s_sys_readlink, "%readlink", 1, 0, 0, scm_sys_readlink); +#ifdef __STDC__ +SCM +scm_sys_readlink(SCM path) +#else +SCM +scm_sys_readlink(path) + SCM path; +#endif +{ +#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) + result = scm_makfromstr (buf, rv, 0); + else + result = SCM_MAKINUM (errno); + scm_must_free (buf); + SCM_ALLOW_INTS; + return result; +#else + return SCM_MAKINUM (ENOSYS); +#endif +} + + +SCM_PROC (s_sys_lstat, "%lstat", 1, 0, 0, scm_sys_lstat); +#ifdef __STDC__ +SCM +scm_sys_lstat(SCM str) +#else +SCM +scm_sys_lstat(str) + SCM str; +#endif +{ +#ifdef HAVE_LSTATE + int i; + struct stat stat_temp; + SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, (char *)SCM_ARG1, s_sys_lstat); + SCM_SYSCALL(i = lstat(SCM_CHARS(str), &stat_temp)); + return i ? SCM_MAKINUM (errno) : scm_stat2scm(&stat_temp); +#else + return SCM_MAKINUM (ENOSYS); +#endif +} + + +SCM_PROC (s_sys_copy_file, "%copy-file", 2, 0, 0, scm_sys_copy_file); +#ifdef __STDC__ +SCM +scm_sys_copy_file (SCM oldfile, SCM newfile) +#else +SCM +scm_sys_copy_file (oldfile, newfile) + SCM oldfile; + SCM newfile; +#endif +{ + 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) + return SCM_BOOL_F; + SCM_DEFER_INTS; + oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY); + if (oldfd == -1) + { + SCM_ALLOW_INTS; + return SCM_BOOL_F; + } + /* should probably use the POSIX flags instead of 07777. */ + newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC, + oldstat.st_mode & 07777); + if (newfd == -1) + { + close (oldfd); + SCM_ALLOW_INTS; + return SCM_BOOL_F; + } + while ((n = read (oldfd, buf, sizeof buf)) > 0) + if (write (newfd, buf, n) != n) + { + close (oldfd); + close (newfd); + SCM_ALLOW_INTS; + return SCM_BOOL_F; + } + close (oldfd); + if (close (newfd) == -1) + { + SCM_ALLOW_INTS; + return SCM_BOOL_F; + } + SCM_ALLOW_INTS; + return SCM_BOOL_T; +} + + +#ifdef __STDC__ +void +scm_init_filesys (void) +#else +void +scm_init_filesys () +#endif +{ + /* 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 + + + 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 new file mode 100644 index 000000000..9949d383b --- /dev/null +++ b/libguile/filesys.h @@ -0,0 +1,135 @@ +/* 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 "_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)) + + + +#ifdef __STDC__ +extern SCM scm_sys_chown (SCM path, SCM owner, SCM group); +extern SCM scm_sys_chmod (SCM port_or_path, SCM mode); +extern SCM scm_umask (SCM mode); +extern SCM scm_intern_fd (int fd, int flags); +extern SCM scm_sys_open (SCM path, SCM flags, SCM mode); +extern SCM scm_sys_create (SCM path, SCM mode); +extern SCM scm_sys_close (SCM sfd); +extern SCM scm_sys_write_fd (SCM sfd, SCM buf); +extern SCM scm_sys_read_fd (SCM sfd, SCM buf, SCM offset, SCM length); +extern SCM scm_sys_lseek (SCM sfd, SCM offset, SCM whence); +extern SCM scm_sys_dup (SCM oldfd, SCM newfd); +extern SCM scm_sys_stat (SCM fd_or_path); +extern SCM scm_sys_link (SCM oldpath, SCM newpath); +extern SCM scm_sys_rename (SCM oldname, SCM newname); +extern SCM scm_sys_mkdir (SCM path, SCM mode); +extern SCM scm_sys_rmdir (SCM path); +extern SCM scm_sys_opendir (SCM dirname); +extern SCM scm_sys_readdir (SCM port); +extern SCM scm_rewinddir (SCM port); +extern SCM scm_sys_closedir (SCM port); +extern SCM scm_sys_chdir (SCM str); +extern SCM scm_sys_getcwd (void); +extern SCM scm_sys_select (SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs); +extern SCM scm_sys_symlink(SCM oldpath, SCM newpath); +extern SCM scm_sys_readlink(SCM path); +extern SCM scm_sys_lstat(SCM str); +extern SCM scm_sys_copy_file (SCM oldfile, SCM newfile); +extern void scm_init_filesys (void); + +#else /* STDC */ +extern SCM scm_sys_chown (); +extern SCM scm_sys_chmod (); +extern SCM scm_umask (); +extern SCM scm_intern_fd (); +extern SCM scm_sys_open (); +extern SCM scm_sys_create (); +extern SCM scm_sys_close (); +extern SCM scm_sys_write_fd (); +extern SCM scm_sys_read_fd (); +extern SCM scm_sys_lseek (); +extern SCM scm_sys_dup (); +extern SCM scm_sys_stat (); +extern SCM scm_sys_link (); +extern SCM scm_sys_rename (); +extern SCM scm_sys_mkdir (); +extern SCM scm_sys_rmdir (); +extern SCM scm_sys_opendir (); +extern SCM scm_sys_readdir (); +extern SCM scm_rewinddir (); +extern SCM scm_sys_closedir (); +extern SCM scm_sys_chdir (); +extern SCM scm_sys_getcwd (); +extern SCM scm_sys_select (); +extern SCM scm_sys_symlink(); +extern SCM scm_sys_readlink(); +extern SCM scm_sys_lstat(); +extern SCM scm_sys_copy_file (); +extern void scm_init_filesys (); + +#endif /* STDC */ + +#endif /* FILESYSH */ diff --git a/libguile/fports.c b/libguile/fports.c new file mode 100644 index 000000000..234c21d26 --- /dev/null +++ b/libguile/fports.c @@ -0,0 +1,391 @@ +/* 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" +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#else +char *ttyname (); +char *tmpnam (); +scm_sizet fwrite (); +#endif +#ifdef HAVE_STRING_H +#include "string.h" +#endif + + +#ifdef __IBMC__ +#include <io.h> +#include <direct.h> +#define ttyname(x) "CON:" +#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 */ +#ifdef __STDC__ +SCM +scm_setbuf0 (SCM port) +#else +SCM +scm_setbuf0 (port) + SCM port; +#endif +{ +#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 + */ +#ifdef __STDC__ +long +scm_mode_bits (char *modes) +#else +long +scm_mode_bits (modes) + char *modes; +#endif +{ + 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. + */ + +#ifdef __STDC__ +SCM +scm_mkfile (char * name, char * modes) +#else +SCM +scm_mkfile (name, modes) + char * name; + char * modes; +#endif +{ + register SCM port; + FILE *f; + SCM_NEWCELL (port); + SCM_DEFER_INTS; + SCM_SYSCALL (f = fopen (name, modes)); + if (!f) + { + SCM_ALLOW_INTS; + port = SCM_BOOL_F; + } + else + { + struct scm_port_table * pt; + pt = scm_add_to_port_table (port); + SCM_SETPTAB_ENTRY (port, pt); + if (SCM_BUF0 & (SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (modes))) + scm_setbuf0 (port); + SCM_SETSTREAM (port, (SCM)f); + SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name); + SCM_ALLOW_INTS; + } + return port; +} + +SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file); +#ifdef __STDC__ +SCM +scm_open_file (SCM filename, SCM modes) +#else +SCM +scm_open_file (filename, modes) + SCM filename; + SCM modes; +#endif +{ + SCM port; + 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); + port = scm_mkfile (SCM_ROCHARS (filename), SCM_ROCHARS (modes)); + /* Force the compiler to keep filename and modes alive: + */ + if (port == SCM_BOOL_F) + scm_cons (filename, modes); + 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); +#ifdef __STDC__ +SCM +scm_port_mode (SCM port) +#else +SCM +scm_port_mode (port) + SCM port; +#endif +{ + 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); +} + + +#ifdef __STDC__ +static int +prinfport (SCM exp, SCM port, int writing) +#else +static int +prinfport (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + 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; +} + + +#ifdef __STDC__ +static int +scm_fgetc (FILE * s) +#else +static int +scm_fgetc (s) + FILE * s; +#endif +{ + if (feof (s)) + return EOF; + else + return fgetc (s); +} + +#ifdef vms +#ifdef __STDC__ +static scm_sizet +pwrite (char *ptr, scm_sizet size, nitems, FILE *port) +#else +static scm_sizet +pwrite (ptr, size, nitems, port) + char *ptr; + scm_sizet size, nitems; + FILE *port; +#endif +{ + 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 (fp) + FILE * fp; +{ + return fclose (fp); +} + +static int +local_fflush (fp) + FILE * fp; +{ + return fflush (fp); +} + +static int +local_fputc (c, fp) + int c; + FILE * fp; +{ + return fputc (c, fp); +} + +static int +local_fputs (s, fp) + char * s; + FILE * fp; +{ + return fputs (s, 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, + local_fclose, + prinfport, + 0, + local_fputc, + local_fputs, + local_ffwrite, + local_fflush, + scm_fgetc, + 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, + local_fputc, + local_fputs, + local_ffwrite, + local_fflush, + scm_fgetc, + 0 +}; /* replaced by pclose in scm_init_ioext() */ + + +#ifdef __STDC__ +void +scm_init_fports (void) +#else +void +scm_init_fports () +#endif +{ +#include "fports.x" +} + diff --git a/libguile/fports.h b/libguile/fports.h new file mode 100644 index 000000000..a0ca6fe3b --- /dev/null +++ b/libguile/fports.h @@ -0,0 +1,78 @@ +/* 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 "__scm.h" + + + +extern scm_ptobfuns scm_fptob; +extern scm_ptobfuns scm_pipob; + + +#ifdef __STDC__ +extern SCM scm_setbuf0 (SCM port); +extern long scm_mode_bits (char *modes); +extern SCM scm_mkfile (char * name, char * modes); +extern SCM scm_open_file (SCM filename, SCM modes); +extern SCM scm_port_mode (SCM port); +extern void scm_init_fports (void); + +#else /* STDC */ +extern SCM scm_setbuf0 (); +extern long scm_mode_bits (); +extern SCM scm_mkfile (); +extern SCM scm_open_file (); +extern SCM scm_port_mode (); +extern void scm_init_fports (); + +#endif /* STDC */ + + + + + + +#endif /* FPORTSH */ diff --git a/libguile/gc.c b/libguile/gc.c new file mode 100644 index 000000000..26e718158 --- /dev/null +++ b/libguile/gc.c @@ -0,0 +1,1690 @@ +/* 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" + +#ifdef HAVE_MALLOC_H +#include "malloc.h" +#endif + +#ifdef HAVE_UNISTD_H +#include "unistd.h" +#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. + */ + +#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 + +/* 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 +{ + SCM_CELLPTR bounds[2]; /* lower and upper */ + SCM *freelistp; /* the value of this may be shared */ + int ncells; /* per object in this segment */ + int (*valid) (); +}; + + + + + +static void alloc_some_heap (); +static void scm_mark_weak_vector_spines (); + + + + +/* {Scheme Interface to GC} + */ + +SCM_PROC (s_gc_stats, "gc-stats", 0, 0, 0, scm_gc_stats); +#ifdef __STDC__ +SCM +scm_gc_stats (void) +#else +SCM +scm_gc_stats () +#endif +{ + 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; +} + + +#ifdef __STDC__ +void +scm_gc_start (char *what) +#else +void +scm_gc_start (what) + char *what; +#endif +{ + 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; +} + +#ifdef __STDC__ +void +scm_gc_end (void) +#else +void +scm_gc_end () +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_gc (void) +#else +SCM +scm_gc () +#endif +{ + SCM_DEFER_INTS; + scm_igc ("call"); + SCM_ALLOW_INTS; + return SCM_UNSPECIFIED; +} + + + +/* {C Interface For When GC is Triggered} + */ + +#ifdef __STDC__ +void +scm_gc_for_alloc (int ncells, SCM * freelistp) +#else +void +scm_gc_for_alloc (ncells, freelistp) + int ncells; + SCM * freelistp; +#endif +{ + 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; +} + + +#ifdef __STDC__ +SCM +scm_gc_for_newcell (void) +#else +SCM +scm_gc_for_newcell () +#endif +{ + SCM fl; + scm_gc_for_alloc (1, &scm_freelist); + fl = scm_freelist; + scm_freelist = SCM_CDR (fl); + return fl; +} + +#ifdef __STDC__ +void +scm_igc (char *what) +#else +void +scm_igc (what) + char *what; +#endif +{ + int j; + + 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_CDR (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; + } + } + + /* 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_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 + } + + + /* 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]); + + scm_gc_mark (scm_rootcont); + scm_gc_mark (scm_dynwinds); + scm_gc_mark (scm_continuation_stack); + scm_gc_mark (scm_continuation_stack_ptr); + scm_gc_mark (scm_progargs); + scm_gc_mark (scm_exitval); + scm_gc_mark (scm_cur_inp); + scm_gc_mark (scm_cur_outp); + scm_gc_mark (scm_cur_errp); + scm_gc_mark (scm_def_inp); + scm_gc_mark (scm_def_outp); + scm_gc_mark (scm_def_errp); + scm_gc_mark (scm_top_level_lookup_thunk_var); + scm_gc_mark (scm_system_transformer); + + scm_mark_weak_vector_spines (); + + scm_gc_sweep (); + + --scm_gc_heap_lock; + scm_gc_end (); +} + + +/* {Mark/Sweep} + */ + + + +/* Mark an object precisely. + */ +#ifdef __STDC__ +void +scm_gc_mark (SCM p) +#else +void +scm_gc_mark (p) + SCM p; +#endif +{ + 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; + SCM * mem; + int x; + + vtable_data = (SCM *)vcell; + layout = vtable_data[scm_struct_i_layout]; + len = SCM_LENGTH (layout); + fields_desc = SCM_CHARS (layout); + mem = (SCM *)SCM_GCCDR (ptr); /* like struct_data but removes mark */ + + for (x = 0; x < len; x += 2) + if (fields_desc[x] == 'p') + scm_gc_mark (mem[x / 2]); + 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 (regs) / 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_CDR (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 + */ + +#ifdef __STDC__ +void +scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) +#else +void +scm_mark_locations (x, n) + SCM_STACKITEM x[]; + scm_sizet n; +#endif +{ + 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; + } + + } + } +} + + +#ifdef __STDC__ +void +scm_mark_weak_vector_spines (void) +#else +void +scm_mark_weak_vector_spines () +#endif +{ + 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); + } + } + } + } +} + + + +#ifdef __STDC__ +void +scm_gc_sweep (void) +#else +void +scm_gc_sweep () +#endif +{ + 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; + i = 0; + + while (i < scm_n_heap_segs) + { + hp_freelist = scm_heap_table[i].freelistp; + nfreelist = SCM_EOL; + 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; + ++i; + 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_CDR (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 * mem; + SCM amt; + mem = (SCM *)SCM_CDR (scmptr); + amt = mem[-2]; + free (mem - 2); + m += amt * sizeof (SCM); + } + } + 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 (regs); + 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_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 + SCM_CAR (scmptr) = (SCM) scm_tc_free_cell; + SCM_CDR (scmptr) = nfreelist; + nfreelist = scmptr; +#if 0 + if ((nfreelist < scm_heap_table[0].bounds[0]) || + (nfreelist >= scm_heap_table[0].bounds[1])) + exit (1); +#endif + 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 - 1].bounds[0]); + scm_heap_table[i - 1].bounds[0] = 0; + for (j = i; j < scm_n_heap_segs; j++) + scm_heap_table[j - 1] = scm_heap_table[j]; + scm_n_heap_segs -= 1; + i -= 1; /* need to scan segment just moved. */ + } + else +#endif /* ifdef GC_FREE_SEGMENTS */ + *hp_freelist = nfreelist; + + 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_CDR (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. + */ +#ifdef __STDC__ +char * +scm_must_malloc (long len, char *what) +#else +char * +scm_must_malloc (len, what) + long len; + char *what; +#endif +{ + 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 = nm + nm / 2; + return ptr; + } + goto malerr; +} + + +/* scm_must_realloc + * is similar to scm_must_malloc. + */ +#ifdef __STDC__ +char * +scm_must_realloc (char *where, long olen, long len, char *what) +#else +char * +scm_must_realloc (where, olen, len, what) + char *where; + long olen; + long len; + char *what; +#endif +{ + 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 = nm + nm / 2; + return ptr; + } + goto ralerr; +} + +/* scm_must_free + * is for releasing memory from scm_must_realloc and scm_must_malloc. + */ +#ifdef __STDC__ +void +scm_must_free (char *obj) +#else +void +scm_must_free (obj) + char *obj; +#endif +{ + 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. + */ + + +#ifdef __STDC__ +static scm_sizet +init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, int ncells, SCM *freelistp) +#else +static scm_sizet +init_heap_seg (seg_org, size, ncells, freelistp) + SCM_CELLPTR seg_org; + scm_sizet size; + int ncells; + SCM *freelistp; +#endif +{ + 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_CAR (scmptr) = (SCM) scm_tc_free_cell; + SCM_CDR (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_CDR (PTR2SCM (ptr)) = *freelistp; + *freelistp = PTR2SCM (CELL_UP (seg_org)); + + scm_heap_size += (ncells * n_new_objects); + return size; +#ifdef scmptr +#undef scmptr +#endif +} + + +#ifdef __STDC__ +static void +alloc_some_heap (int ncells, SCM * freelistp) +#else +static void +alloc_some_heap (ncells, freelistp) + int ncells; + SCM * freelistp; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_unhash_name (SCM name) +#else +SCM +scm_unhash_name (name) + SCM name; +#endif +{ + 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} + */ + + +#ifdef __STDC__ +void +scm_remember (SCM * ptr) +#else +void +scm_remember (ptr) + SCM * ptr; +#endif +{} + +#ifdef __STDC__ +SCM +scm_return_first (SCM elt, ...) +#else +SCM +scm_return_first (elt, va_alist) + SCM elt; + va_dcl +#endif +{ + return elt; +} + + +#ifdef __STDC__ +SCM +scm_permanent_object (SCM obj) +#else +SCM +scm_permanent_object (obj) + SCM obj; +#endif +{ + SCM_REDEFER_INTS; + scm_permobjs = scm_cons (obj, scm_permobjs); + SCM_REALLOW_INTS; + return obj; +} + + + +#ifdef __STDC__ +int +scm_init_storage (long init_heap_size) +#else +int +scm_init_storage (init_heap_size) + long init_heap_size; +#endif +{ + 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_CDR (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_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_permobjs = 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; +} + + +#ifdef __STDC__ +void +scm_init_gc (void) +#else +void +scm_init_gc () +#endif +{ +#include "gc.x" +} + diff --git a/libguile/gc.h b/libguile/gc.h new file mode 100644 index 000000000..8760811a9 --- /dev/null +++ b/libguile/gc.h @@ -0,0 +1,118 @@ +/* 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 "__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 __STDC__ +extern SCM scm_gc_stats (void); +extern void scm_gc_start (char *what); +extern void scm_gc_end (void); +extern SCM scm_gc (void); +extern void scm_gc_for_alloc (int ncells, SCM * freelistp); +extern SCM scm_gc_for_newcell (void); +extern void scm_igc (char *what); +extern void scm_gc_mark (SCM p); +extern void scm_mark_locations (SCM_STACKITEM x[], scm_sizet n); +extern void scm_gc_sweep (void); +extern char * scm_must_malloc (long len, char *what); +extern char * scm_must_realloc (char *where, long olen, long len, char *what); +extern void scm_must_free (char *obj); +extern void scm_remember (SCM * ptr); +extern SCM scm_return_first (SCM elt, ...); +extern SCM scm_permanent_object (SCM obj); +extern SCM scm_protect_object (SCM obj); +extern SCM scm_unprotect_object (SCM obj); +extern int scm_init_storage (long init_heap_size); +extern void scm_init_gc (void); + +#else /* STDC */ +extern SCM scm_gc_stats (); +extern void scm_gc_start (); +extern void scm_gc_end (); +extern SCM scm_gc (); +extern void scm_gc_for_alloc (); +extern SCM scm_gc_for_newcell (); +extern void scm_igc (); +extern void scm_gc_mark (); +extern void scm_mark_locations (); +extern void scm_gc_sweep (); +extern char * scm_must_malloc (); +extern char * scm_must_realloc (); +extern void scm_must_free (); +extern void scm_remember (); +extern SCM scm_return_first (); +extern SCM scm_permanent_object (); +extern SCM scm_protect_object (); +extern SCM scm_unprotect_object (); +extern int scm_init_storage (); +extern void scm_init_gc (); + +#endif /* STDC */ +#include "marksweep.h" +#endif /* GCH */ diff --git a/libguile/genio.c b/libguile/genio.c new file mode 100644 index 000000000..6bc082536 --- /dev/null +++ b/libguile/genio.c @@ -0,0 +1,533 @@ +/* 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" + + + + +#ifdef __STDC__ +static void +scm_putc (int c, SCM port) +#else +static void +scm_putc (c, port) + int c; + SCM port; +#endif +{ + scm_sizet i = SCM_PTOBNUM (port); + SCM_SYSCALL ((scm_ptobs[i].fputc) (c, SCM_STREAM (port))); +} + + +#ifdef __STDC__ +static void +scm_puts (char *s, SCM port) +#else +static void +scm_puts (s, port) + char *s; + SCM port; +#endif +{ + 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 +} + + +#ifdef __STDC__ +static int +scm_lfwrite (char *ptr, scm_sizet size, scm_sizet nitems, SCM port) +#else +static int +scm_lfwrite (ptr, size, nitems, port) + char *ptr; + scm_sizet size; + scm_sizet nitems; + SCM port; +#endif +{ + 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; +} + + + + +#ifdef __STDC__ +void +scm_gen_putc (int c, SCM port) +#else +void +scm_gen_putc (c, port) + int c; + SCM port; +#endif +{ + 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; + } + } +} + + + + + +#ifdef __STDC__ +void +scm_gen_puts (enum scm_string_representation_type rep, + char *str_data, + SCM port) +#else +void +scm_gen_puts (rep, str_data, port) + enum scm_string_representation_type rep; + unsigned char *str_data; + SCM port; +#endif +{ + 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 *)wstr_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; + } + } + } + } +} + + + + +#ifdef __STDC__ +void +scm_gen_write (enum scm_string_representation_type rep, char *str_data, scm_sizet nitems, SCM port) +#else +void +scm_gen_write (rep, str_data, nitems, port) + enum scm_string_representation_type rep; + char *str_data; + scm_sizet nitems; + SCM port; +#endif +{ + /* 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 *)wstr_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; + } + } + } + } +} + + + + +#ifdef __STDC__ +static int +scm_getc (SCM port) +#else +static int +scm_getc (port) + SCM port; +#endif +{ + FILE *f; + int c; + scm_sizet i; + + f = (FILE *)SCM_STREAM (port); + i = SCM_PTOBNUM (port); + SCM_SYSCALL (c = (scm_ptobs[i].fgetc) (f)); + return c; +} + +#ifdef __STDC__ +int +scm_gen_getc (SCM port) +#else +int +scm_gen_getc (port) + SCM port; +#endif +{ + 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]; + int c; + + 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; + } +} + +#ifdef __STDC__ +void +scm_gen_ungetc (int c, SCM port) +#else +void +scm_gen_ungetc (c, port) + int c; + SCM port; +#endif +{ +/* 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 new file mode 100644 index 000000000..30275211b --- /dev/null +++ b/libguile/genio.h @@ -0,0 +1,69 @@ +/* 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 "__scm.h" +#include "ports.h" + + +#ifdef __STDC__ +extern void scm_gen_putc (int c, SCM port); +extern void scm_gen_puts (enum scm_string_representation_type rep, + char *str_data, + SCM port); +extern void scm_gen_write (enum scm_string_representation_type rep, char *str_data, scm_sizet nitems, SCM port); +extern int scm_gen_getc (SCM port); +extern void scm_gen_ungetc (int c, SCM port); + +#else /* STDC */ +extern void scm_gen_putc (); +extern void scm_gen_puts (); +extern void scm_gen_write (); +extern int scm_gen_getc (); +extern void scm_gen_ungetc (); + +#endif /* STDC */ + +#endif /* GENIOH */ diff --git a/libguile/gscm.c b/libguile/gscm.c new file mode 100644 index 000000000..5eedc9755 --- /dev/null +++ b/libguile/gscm.c @@ -0,0 +1,657 @@ +/* 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} + */ + +#ifdef __STDC__ +static GSCM_status +gscm_portprint_obj (SCM port, SCM obj) +#else +static GSCM_status +gscm_portprint_obj (port, obj) + SCM port; + SCM obj; +#endif +{ + scm_iprin1 (obj, port, 1); + return GSCM_OK; +} + + +struct seval_str_frame +{ + GSCM_status status; + SCM * answer; + GSCM_top_level top; + char * str; +}; + +#ifdef __STDC__ +static void +_seval_str_fn (void * vframe) +#else +static void +_seval_str_fn (vframe) + void * vframe; +#endif +{ + struct seval_str_frame * frame; + frame = (struct seval_str_frame *)vframe; + frame->status = gscm_seval_str (frame->answer, frame->top, frame->str); +} + + + +#ifdef __STDC__ +static GSCM_status +gscm_strprint_obj (SCM * answer, SCM obj) +#else +static GSCM_status +gscm_strprint_obj (answer, obj) + SCM * answer; + SCM obj; +#endif +{ + 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; +} + +#ifdef __STDC__ +static GSCM_status +gscm_cstr (char ** answer, SCM obj) +#else +static GSCM_status +gscm_cstr (answer, obj) + char ** answer; + SCM obj; +#endif +{ + 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} + */ + +#ifdef __STDC__ +static SCM +gscm_silent_repl (SCM env) +#else +static SCM +gscm_silent_repl (env) + SCM env; +#endif +{ + 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 + +#ifdef __STDC__ +static GSCM_status +_eval_port (SCM * answer, GSCM_top_level toplvl, SCM port, int printp) +#else +static GSCM_status +_eval_port (answer, toplvl, port, printp) + SCM * answer; + GSCM_top_level toplvl; + SCM port; + int printp; +#endif +{ + 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) = last_debug_info_frame = 0; +#endif + saved_inp = scm_cur_inp; + i = setjmp (SCM_JMPBUF (scm_rootcont)); +#ifdef SCM_STACK_CHECK + scm_check_stack_p = 1; +#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; +} + +#ifdef __STDC__ +static GSCM_status +seval_str (SCM *answer, GSCM_top_level toplvl, char * str) +#else +static GSCM_status +seval_str (answer, toplvl, str) + SCM *answer; + GSCM_top_level toplvl; + char * str; +#endif +{ + 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; +} + + +#ifdef __STDC__ +GSCM_status +gscm_seval_str (SCM *answer, GSCM_top_level toplvl, char * str) +#else +GSCM_status +gscm_seval_str (answer, toplvl, str) + SCM *answer; + GSCM_top_level toplvl; + char * str; +#endif +{ + SCM_STACKITEM i; + GSCM_status status; + scm_stack_base = &i; + status = seval_str (answer, toplvl, str); + scm_stack_base = 0; + return status; +} + +#ifdef __STDC__ +void +format_load_command (char * buf, char *file_name) +#else +void +format_load_command (buf, file_name) + char * buf; + char *file_name; +#endif +{ + 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); +} + +#ifdef __STDC__ +GSCM_status +gscm_seval_file (SCM *answer, GSCM_top_level toplvl, char * file_name) +#else +GSCM_status +gscm_seval_file (answer, toplvl, file_name) + SCM *answer; + GSCM_top_level toplvl; + char * file_name; +#endif +{ + char command[MAXPATHLEN * 3]; + format_load_command (command, file_name); + return gscm_seval_str (answer, toplvl, command); +} + + +#ifdef __STDC__ +static GSCM_status +eval_str (char ** answer, GSCM_top_level toplvl, char * str) +#else +static GSCM_status +eval_str (answer, toplvl, str) + char ** answer; + GSCM_top_level toplvl; + char * str; +#endif +{ + 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; +} + + +#ifdef __STDC__ +GSCM_status +gscm_eval_str (char ** answer, GSCM_top_level toplvl, char * str) +#else +GSCM_status +gscm_eval_str (answer, toplvl, str) + char ** answer; + GSCM_top_level toplvl; + char * str; +#endif +{ + SCM_STACKITEM i; + GSCM_status status; + scm_stack_base = &i; + status = eval_str (answer, toplvl, str); + scm_stack_base = 0; + return status; +} + + +#ifdef __STDC__ +GSCM_status +gscm_eval_file (char ** answer, GSCM_top_level toplvl, char * file_name) +#else +GSCM_status +gscm_eval_file (answer, toplvl, file_name) + char ** answer; + GSCM_top_level toplvl; + char * file_name; +#endif +{ + 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." +}; + +#ifdef __STDC__ +char * +gscm_error_msg (int n) +#else +char * +gscm_error_msg (n) + int n; +#endif +{ + if ((n < 0) || (n > (sizeof (gscm_error_msgs) / sizeof (char *)))) + return "Unrecognized error."; + else + return gscm_error_msgs[n]; +} + + + +/* {Defining New Procedures} + */ + +#ifdef __STDC__ +SCM +gscm_make_subr (SCM (*fn)(), int req, int opt, int varp, char * doc) +#else +SCM +gscm_make_subr (fn, req, opt, varp, doc) + SCM (*fn)(); + int req; + int opt; + int varp; + char * doc; +#endif +{ + return scm_make_gsubr ("*anonymous*", req, opt, varp, fn); +} + +#ifdef __STDC__ +int +gscm_2_char (SCM c) +#else +int +gscm_2_char (c) + SCM c; +#endif +{ + SCM_ASSERT (SCM_ICHRP (c), c, SCM_ARG1, "gscm_2_char"); + return SCM_ICHR (c); +} + + + +#ifdef __STDC__ +void +gscm_2_str (char ** out, int * len_out, SCM * objp) +#else +void +gscm_2_str (out, len_out, objp) + char ** out; + int * len_out; + SCM * objp; +#endif +{ + 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); +} + + +#ifdef __STDC__ +void +gscm_error (char * message, SCM args) +#else +void +gscm_error (message, args) + char * message; + SCM args; +#endif +{ + SCM errsym; + SCM str; + + errsym = SCM_CAR (scm_intern ("error", 5)); + str = scm_makfrom0str (message); + scm_throw (errsym, scm_cons (str, args)); +} + + +#ifdef __STDC__ +GSCM_status +gscm_run_scm (int argc, char ** argv, FILE * in, FILE * out, FILE * err, GSCM_status (*initfn)(), char * initfile, char * initcmd) +#else +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; +#endif +{ + 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_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; +} + + + +#ifdef __STDC__ +void +scm_init_guile (void) +#else +void +scm_init_guile () +#endif +{ +#include "gscm.x" +} + diff --git a/libguile/gscm.h b/libguile/gscm.h new file mode 100644 index 000000000..c6ac44b5f --- /dev/null +++ b/libguile/gscm.h @@ -0,0 +1,297 @@ +/* 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_iprin1 +#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 + + + +#ifdef __STDC__ +extern GSCM_status gscm_seval_str (SCM *answer, GSCM_top_level toplvl, char * str); +extern GSCM_status gscm_seval_file (SCM *answer, GSCM_top_level toplvl, char * file_name); +extern GSCM_status gscm_eval_str (char ** answer, GSCM_top_level toplvl, char * str); +extern GSCM_status gscm_eval_file (char ** answer, GSCM_top_level toplvl, char * file_name); +extern GSCM_status gscm_run_scm (int argc, char ** argv, FILE * in, FILE * out, FILE * err, GSCM_status (*initfn)(), char * initfile, char * initcmd); +extern char * gscm_error_msg (int n); +extern SCM gscm_make_subr (SCM (*fn)(), int req, int opt, int varp, char * doc); +extern int gscm_2_char (SCM c); +extern void gscm_2_str (char ** out, int * len_out, SCM * objp); +extern void gscm_error (char * message, SCM args); +extern void scm_init_guile (void); + +#else /* STDC */ +extern GSCM_status gscm_seval_str (); +extern void format_load_command (); +extern GSCM_status gscm_seval_file (); +extern GSCM_status gscm_eval_str (); +extern GSCM_status gscm_eval_file (); +extern char * gscm_error_msg (); +extern SCM gscm_make_subr (); +extern int gscm_2_char (); +extern void gscm_2_str (); +extern void gscm_error (); +extern GSCM_status gscm_run_scm (); +extern void scm_init_guile (); + +#endif /* STDC */ +#endif /* GSCMH */ + diff --git a/libguile/gsubr.c b/libguile/gsubr.c new file mode 100644 index 000000000..2f1cc75e9 --- /dev/null +++ b/libguile/gsubr.c @@ -0,0 +1,195 @@ +/* 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" + + +/* + * 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]) + +static SCM f_gsubr_apply; +#ifdef __STDC__ +SCM +scm_make_gsubr(char *name, int req, int opt, int rst, SCM (*fcn)()) +#else +SCM +scm_make_gsubr(name, req, opt, rst, fcn) + char *name; + int req; + int opt; + int rst; + SCM (*fcn)(); +#endif +{ + 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_CAR(z) = tmp + scm_tc7_subr_0; + GSUBR_PROC(cclo) = z; + GSUBR_TYPE(cclo) = SCM_MAKINUM(GSUBR_MAKTYPE(req, opt, rst)); + SCM_CDR(symcell) = cclo; + return cclo; + } + } +} + + +SCM_PROC(s_gsubr_apply, "gsubr-apply", 0, 0, 1, scm_gsubr_apply); +#ifdef __STDC__ +SCM +scm_gsubr_apply(SCM args) +#else +SCM +scm_gsubr_apply(args) + SCM args; +#endif +{ + 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_wta(SCM_UNDEFINED, (char *)SCM_WNA, SCM_CHARS(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 + + +#ifdef __STDC__ +void +scm_init_gsubr(void) +#else +void +scm_init_gsubr() +#endif +{ + f_gsubr_apply = scm_make_subr(s_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply); +#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 new file mode 100644 index 000000000..4aed7ef0a --- /dev/null +++ b/libguile/gsubr.h @@ -0,0 +1,65 @@ +/* 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 "__scm.h" + + +#ifdef __STDC__ +extern SCM scm_make_gsubr(char *name, int req, int opt, int rst, SCM (*fcn)()); +extern SCM scm_gsubr_apply(SCM args); +extern void scm_init_gsubr(void); + +#else /* STDC */ +extern SCM scm_make_gsubr(); +extern SCM scm_gsubr_apply(); +extern void scm_init_gsubr(); + +#endif /* STDC */ + + + + +#endif /* GSUBRH */ diff --git a/libguile/hash.c b/libguile/hash.c new file mode 100644 index 000000000..48f171a61 --- /dev/null +++ b/libguile/hash.c @@ -0,0 +1,252 @@ +/* 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" + + + +#ifndef floor +extern double floor(); +#endif + +#ifdef __STDC__ +unsigned long +scm_hasher(SCM obj, unsigned long n, scm_sizet d) +#else +unsigned long +scm_hasher(obj, n, d) + SCM obj; + unsigned long n; + scm_sizet d; +#endif +{ + 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; + } + } +} + + + + +#ifdef __STDC__ +unsigned int +scm_ihashq (SCM obj, unsigned int n) +#else +unsigned int +scm_ihashq (obj, n) + SCM obj; + unsigned int n; +#endif +{ + return (((unsigned int) obj) >> 1) % n; +} + + +SCM_PROC(s_hashq, "hashq", 2, 0, 0, scm_hashq); +#ifdef __STDC__ +SCM +scm_hashq(SCM obj, SCM n) +#else +SCM +scm_hashq(obj, n) + SCM obj; + SCM n; +#endif +{ + SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashq); + return SCM_MAKINUM(scm_ihashq (obj, SCM_INUM (n))); +} + + + + +#ifdef __STDC__ +unsigned int +scm_ihashv (SCM obj, unsigned int n) +#else +unsigned int +scm_ihashv (obj, n) + SCM obj; + unsigned int n; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashv(SCM obj, SCM n) +#else +SCM +scm_hashv(obj, n) + SCM obj; + SCM n; +#endif +{ + SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashv); + return SCM_MAKINUM(scm_ihashv (obj, SCM_INUM (n))); +} + + + + +#ifdef __STDC__ +unsigned int +scm_ihash (SCM obj, unsigned int n) +#else +unsigned int +scm_ihash (obj, n) + SCM obj; + unsigned int n; +#endif +{ + return (unsigned int)scm_hasher (obj, n, 10); +} + +SCM_PROC(s_hash, "hash", 2, 0, 0, scm_hash); +#ifdef __STDC__ +SCM +scm_hash(SCM obj, SCM n) +#else +SCM +scm_hash(obj, n) + SCM obj; + SCM n; +#endif +{ + SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hash); + return SCM_MAKINUM(scm_ihash(obj, SCM_INUM(n))); +} + + + + +#ifdef __STDC__ +void +scm_init_hash (void) +#else +void +scm_init_hash () +#endif +{ +#include "hash.x" +} + diff --git a/libguile/hash.h b/libguile/hash.h new file mode 100644 index 000000000..8c53d3696 --- /dev/null +++ b/libguile/hash.h @@ -0,0 +1,77 @@ +/* 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 "__scm.h" + + +#ifdef __STDC__ +extern unsigned long scm_hasher(SCM obj, unsigned long n, scm_sizet d); +extern unsigned int scm_ihashq (SCM obj, unsigned int n); +extern SCM scm_hashq(SCM obj, SCM n); +extern unsigned int scm_ihashv (SCM obj, unsigned int n); +extern SCM scm_hashv(SCM obj, SCM n); +extern unsigned int scm_ihash (SCM obj, unsigned int n); +extern SCM scm_hash(SCM obj, SCM n); +extern void scm_init_hash (void); + +#else /* STDC */ +extern unsigned long scm_hasher(); +extern unsigned int scm_ihashq (); +extern SCM scm_hashq(); +extern unsigned int scm_ihashv (); +extern SCM scm_hashv(); +extern unsigned int scm_ihash (); +extern SCM scm_hash(); +extern void scm_init_hash (); + +#endif /* STDC */ + + + + + + +#endif /* HASHH */ diff --git a/libguile/hashtab.c b/libguile/hashtab.c new file mode 100644 index 000000000..fd37e2574 --- /dev/null +++ b/libguile/hashtab.c @@ -0,0 +1,651 @@ +/* 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" + + + +#ifdef __STDC__ +SCM +scm_hash_fn_get_handle (SCM table, SCM obj, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure) +#else +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; +#endif +{ + 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; +} + + +#ifdef __STDC__ +SCM +scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure) +#else +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; +#endif +{ + 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); + } +} + + + +#ifdef __STDC__ +SCM +scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure) +#else +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; +#endif +{ + 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); +} + + + +#ifdef __STDC__ +SCM +scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure) +#else +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; +#endif +{ + 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; +} + + + + +#ifdef __STDC__ +SCM +scm_hash_fn_remove_x (SCM table, + SCM obj, + unsigned int (*hash_fn)(), + SCM (*assoc_fn)(), + SCM (*delete_fn)(), + void * closure) +#else +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; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashq_get_handle (SCM table, SCM obj) +#else +SCM +scm_hashq_get_handle (table, obj) + SCM table; + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashq_create_handle_x (SCM table, SCM obj, SCM init) +#else +SCM +scm_hashq_create_handle_x (table, obj, init) + SCM table; + SCM obj; + SCM init; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashq_ref (SCM table, SCM obj, SCM dflt) +#else +SCM +scm_hashq_ref (table, obj, dflt) + SCM table; + SCM obj; + SCM dflt; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashq_set_x (SCM table, SCM obj, SCM val) +#else +SCM +scm_hashq_set_x (table, obj, val) + SCM table; + SCM obj; + SCM val; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashq_remove_x (SCM table, SCM obj) +#else +SCM +scm_hashq_remove_x (table, obj) + SCM table; + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashv_get_handle (SCM table, SCM obj) +#else +SCM +scm_hashv_get_handle (table, obj) + SCM table; + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashv_create_handle_x (SCM table, SCM obj, SCM init) +#else +SCM +scm_hashv_create_handle_x (table, obj, init) + SCM table; + SCM obj; + SCM init; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashv_ref (SCM table, SCM obj, SCM dflt) +#else +SCM +scm_hashv_ref (table, obj, dflt) + SCM table; + SCM obj; + SCM dflt; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashv_set_x (SCM table, SCM obj, SCM val) +#else +SCM +scm_hashv_set_x (table, obj, val) + SCM table; + SCM obj; + SCM val; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashv_remove_x (SCM table, SCM obj) +#else +SCM +scm_hashv_remove_x (table, obj) + SCM table; + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hash_get_handle (SCM table, SCM obj) +#else +SCM +scm_hash_get_handle (table, obj) + SCM table; + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hash_create_handle_x (SCM table, SCM obj, SCM init) +#else +SCM +scm_hash_create_handle_x (table, obj, init) + SCM table; + SCM obj; + SCM init; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hash_ref (SCM table, SCM obj, SCM dflt) +#else +SCM +scm_hash_ref (table, obj, dflt) + SCM table; + SCM obj; + SCM dflt; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hash_set_x (SCM table, SCM obj, SCM val) +#else +SCM +scm_hash_set_x (table, obj, val) + SCM table; + SCM obj; + SCM val; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hash_remove_x (SCM table, SCM obj) +#else +SCM +scm_hash_remove_x (table, obj) + SCM table; + SCM obj; +#endif +{ + 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; +}; + + +#ifdef __STDC__ +static unsigned int +scm_ihashx (SCM obj, unsigned int n, struct scm_ihashx_closure * closure) +#else +static unsigned int +scm_ihashx (obj, n, closure) + SCM obj; + unsigned int n; + struct scm_ihashx_closure * closure; +#endif +{ + 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); +} + + +#ifdef __STDC__ +static SCM +scm_sloppy_assx (SCM obj, SCM alist, struct scm_ihashx_closure * closure) +#else +static SCM +scm_sloppy_assx (obj, alist, closure) + SCM obj; + SCM alist; + struct scm_ihashx_closure * closure; +#endif +{ + SCM answer; + SCM_ALLOW_INTS; + answer = scm_apply (closure->assoc, + scm_listify (obj, alist, SCM_UNDEFINED), + SCM_EOL); + SCM_DEFER_INTS; + return answer; +} + + + +#ifdef __STDC__ +static SCM +scm_delx_x (SCM obj, SCM alist, struct scm_ihashx_closure * closure) +#else +static SCM +scm_delx_x (obj, alist, closure) + SCM obj; + SCM alist; + struct scm_ihashx_closure * closure; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashx_get_handle (SCM hash, SCM assoc, SCM table, SCM obj) +#else +SCM +scm_hashx_get_handle (hash, assoc, table, obj) + SCM hash; + SCM assoc; + SCM table; + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashx_create_handle_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM init) +#else +SCM +scm_hashx_create_handle_x (hash, assoc, table, obj, init) + SCM hash; + SCM assoc; + SCM table; + SCM obj; + SCM init; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashx_ref (SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt) +#else +SCM +scm_hashx_ref (hash, assoc, table, obj, dflt) + SCM hash; + SCM assoc; + SCM table; + SCM obj; + SCM dflt; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_hashx_set_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM val) +#else +SCM +scm_hashx_set_x (hash, assoc, table, obj, val) + SCM hash; + SCM assoc; + SCM table; + SCM obj; + SCM val; +#endif +{ + 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); +} + + +#ifdef __STDC__ +SCM +scm_hashx_remove_x (SCM hash, SCM assoc, SCM delete, SCM table, SCM obj) +#else +SCM +scm_hashx_remove_x (hash, assoc, delete, table, obj) + SCM hash; + SCM assoc; + SCM delete; + SCM table; + SCM obj; +#endif +{ + 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); +} + + + +#ifdef __STDC__ +void +scm_init_hashtab (void) +#else +void +scm_init_hashtab () +#endif +{ +#include "hashtab.x" +} + diff --git a/libguile/hashtab.h b/libguile/hashtab.h new file mode 100644 index 000000000..345303896 --- /dev/null +++ b/libguile/hashtab.h @@ -0,0 +1,118 @@ +/* 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. + */ + + + + +#ifdef __STDC__ +extern SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure); +extern SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure); +extern SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure); +extern SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned int (*hash_fn)(), SCM (*assoc_fn)(), void * closure); +extern SCM scm_hash_fn_remove_x (SCM table, + SCM obj, + unsigned int (*hash_fn)(), + SCM (*assoc_fn)(), + SCM (*delete_fn)(), + void * closure); +extern SCM scm_hashq_get_handle (SCM table, SCM obj); +extern SCM scm_hashq_create_handle_x (SCM table, SCM obj, SCM init); +extern SCM scm_hashq_ref (SCM table, SCM obj, SCM dflt); +extern SCM scm_hashq_set_x (SCM table, SCM obj, SCM val); +extern SCM scm_hashq_remove_x (SCM table, SCM obj); +extern SCM scm_hashv_get_handle (SCM table, SCM obj); +extern SCM scm_hashv_create_handle_x (SCM table, SCM obj, SCM init); +extern SCM scm_hashv_ref (SCM table, SCM obj, SCM dflt); +extern SCM scm_hashv_set_x (SCM table, SCM obj, SCM val); +extern SCM scm_hashv_remove_x (SCM table, SCM obj); +extern SCM scm_hash_get_handle (SCM table, SCM obj); +extern SCM scm_hash_create_handle_x (SCM table, SCM obj, SCM init); +extern SCM scm_hash_ref (SCM table, SCM obj, SCM dflt); +extern SCM scm_hash_set_x (SCM table, SCM obj, SCM val); +extern SCM scm_hash_remove_x (SCM table, SCM obj); +extern SCM scm_hashx_get_handle (SCM hash, SCM assoc, SCM table, SCM obj); +extern SCM scm_hashx_create_handle_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM init); +extern SCM scm_hashx_ref (SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt); +extern SCM scm_hashx_set_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM val); +extern SCM scm_hashx_remove_x (SCM hash, SCM assoc, SCM delete, SCM table, SCM obj); +extern void scm_init_hashtab (void); + +#else /* STDC */ +extern SCM scm_hash_fn_get_handle (); +extern SCM scm_hash_fn_create_handle_x (); +extern SCM scm_hash_fn_ref (); +extern SCM scm_hash_fn_set_x (); +extern SCM scm_hash_fn_remove_x (); +extern SCM scm_hashq_get_handle (); +extern SCM scm_hashq_create_handle_x (); +extern SCM scm_hashq_ref (); +extern SCM scm_hashq_set_x (); +extern SCM scm_hashq_remove_x (); +extern SCM scm_hashv_get_handle (); +extern SCM scm_hashv_create_handle_x (); +extern SCM scm_hashv_ref (); +extern SCM scm_hashv_set_x (); +extern SCM scm_hashv_remove_x (); +extern SCM scm_hash_get_handle (); +extern SCM scm_hash_create_handle_x (); +extern SCM scm_hash_ref (); +extern SCM scm_hash_set_x (); +extern SCM scm_hash_remove_x (); +extern SCM scm_hashx_get_handle (); +extern SCM scm_hashx_create_handle_x (); +extern SCM scm_hashx_ref (); +extern SCM scm_hashx_set_x (); +extern SCM scm_hashx_remove_x (); +extern void scm_init_hashtab (); + +#endif /* STDC */ + + + + + + + +#endif /* HASHTABH */ diff --git a/libguile/inet_aton.c b/libguile/inet_aton.c new file mode 100644 index 000000000..f7ca832f7 --- /dev/null +++ b/libguile/inet_aton.c @@ -0,0 +1,157 @@ +/* + * 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> + +#ifdef 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 new file mode 100644 index 000000000..2f65c15f6 --- /dev/null +++ b/libguile/init.c @@ -0,0 +1,453 @@ +/* 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" + + + +#ifdef __STDC__ +void +scm_start_stack (void * base, FILE * in, FILE * out, FILE * err) +#else +void +scm_start_stack (base, in, out, err) + void * base; + FILE * in; + FILE * out; + FILE * err; +#endif +{ + struct scm_port_table * pt; + + scm_stack_base = base; + + /* Create standar ports from stdio files, if requested to do so. + */ + + if (!in) + { + scm_def_inp = SCM_BOOL_F; + } + else + { + SCM_NEWCELL (scm_def_inp); + pt = scm_add_to_port_table (scm_def_inp); + SCM_CAR (scm_def_inp) = (scm_tc16_fport | SCM_OPN | SCM_RDNG); + SCM_SETPTAB_ENTRY (scm_def_inp, pt); + SCM_SETSTREAM (scm_def_inp, (SCM)in); + if (isatty (fileno (in))) + { + scm_setbuf0 (scm_def_inp); /* turn off stdin buffering */ + SCM_CAR (scm_def_inp) |= SCM_BUF0; + } + scm_set_port_revealed_x (scm_def_inp, SCM_MAKINUM (1)); + } + + if (!out) + { + scm_def_outp = SCM_BOOL_F; + } + else + { + SCM_NEWCELL (scm_def_outp); + pt = scm_add_to_port_table (scm_def_outp); + SCM_CAR (scm_def_outp) = (scm_tc16_fport | SCM_OPN | SCM_WRTNG); + SCM_SETPTAB_ENTRY (scm_def_outp, pt); + SCM_SETSTREAM (scm_def_outp, (SCM)out); + scm_set_port_revealed_x (scm_def_outp, SCM_MAKINUM (1)); + } + + if (!err) + { + scm_def_errp = SCM_BOOL_F; + } + else + { + SCM_NEWCELL (scm_def_errp); + pt = scm_add_to_port_table (scm_def_errp); + SCM_CAR (scm_def_errp) = (scm_tc16_fport | SCM_OPN | SCM_WRTNG); + SCM_SETPTAB_ENTRY (scm_def_errp, pt); + SCM_SETSTREAM (scm_def_errp, (SCM)err); + scm_set_port_revealed_x (scm_def_errp, SCM_MAKINUM (1)); + } + + scm_cur_inp = scm_def_inp; + scm_cur_outp = scm_def_outp; + scm_cur_errp = scm_def_errp; + + + scm_progargs = SCM_BOOL_F; /* vestigial */ + scm_exitval = SCM_BOOL_F; /* vestigial */ + + scm_top_level_lookup_thunk_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 (regs), "continuation")); + SCM_CAR (scm_rootcont) = scm_tc7_contin; + /* 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); +} + + +#ifdef __STDC__ +void +scm_restart_stack (void * base) +#else +void +scm_restart_stack (base) + void * base; +#endif +{ + scm_dynwinds = SCM_EOL; + SCM_DYNENV (scm_rootcont) = SCM_EOL; + SCM_THROW_VALUE (scm_rootcont) = SCM_EOL; + SCM_BASE (scm_rootcont) = base; + scm_continuation_stack_ptr = SCM_MAKINUM (0); +} + +#if 0 +static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define "; + +#ifdef __STDC__ +static void +fixconfig (char *s1, char *s2, int s) +#else +static void +fixconfig (s1, s2, s) + char *s1; + char *s2; + int s; +#endif +{ + 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_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 + + + +#ifdef _UNICOS +typedef int setjmp_type; +#else +typedef long setjmp_type; +#endif + +/* Fire up Scheme. + * + * argc and argv are made the return values of program-arguments. + * + * in, out, and err, if not NULL, become the standard ports. + * If NULL is passed, your "scm_appinit" should set up the + * standard ports. + * + * boot_cmd is a string containing a Scheme expression to evaluate + * to get things rolling. + * + * result is returned a string containing a printed result of evaluating + * the boot command. + * + * the return value is: + * scm_boot_ok - evaluation concluded normally + * scm_boot_error - evaluation concluded with a Scheme error + * scm_boot_emem - allocation error mallocing *result + * scm_boot_ereenter - scm_boot_guile was called re-entrantly, which is prohibited. + */ + +#ifdef __STDC__ +int +scm_boot_guile (char ** result, int argc, char ** argv, FILE * in, FILE * out, FILE * err, char * boot_cmd) +#else +int +scm_boot_guile (result, argc, argv, in, out, err, boot_cmd) + char ** result; + int argc; + char ** argv; + FILE * in; + FILE * out; + FILE * err; + char * boot_cmd; +#endif +{ + static int initialized = 0; + static int live = 0; + SCM_STACKITEM i; + setjmp_type setjmp_val; + int stat; + + if (live) /* This function is not re-entrant. */ + { + return scm_boot_ereenter; + } + + live = 1; + + scm_ints_disabled = 1; + scm_block_gc = 1; + + if (initialized) + { + scm_restart_stack (&i); + } + else + { + 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_feature (); + 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_fdsocket (); + scm_init_fports (); + scm_init_files (); + scm_init_filesys (); + scm_init_gc (); + scm_init_hash (); + scm_init_hashtab (); + scm_init_ioext (); + scm_init_kw (); + scm_init_list (); + scm_init_mallocs (); + scm_init_numbers (); + scm_init_objprop (); + scm_init_pairs (); + scm_init_ports (); + scm_init_posix (); + scm_init_procs (); + scm_init_procprop (); + scm_init_rgx (); + scm_init_scmsigs (); + scm_init_socket (); + scm_init_stackchk (); + scm_init_strports (); + scm_init_struct (); + scm_init_symbols (); + scm_init_tag (); + 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_weaks (); + scm_init_vports (); + scm_init_eval (); + scm_init_ramap (); + scm_init_unif (); + scm_init_simpos (); + scm_appinit (); + scm_progargs = scm_makfromstrs (argc, argv); + initialized = 1; + } + + scm_block_gc = 0; /* permit the gc to run */ + /* ints still disabled */ + + { + SCM command; + + command = scm_makfrom0str (boot_cmd); + + setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont)); + + if (!setjmp_val) + { + SCM last; + scm_init_signals (); + + { + SCM p; + SCM form; + + p = scm_mkstrport (SCM_MAKINUM (0), + command, + SCM_OPN | SCM_RDNG, + "boot_guile"); + while (1) + { + form = scm_read (p, SCM_BOOL_F, SCM_BOOL_F); + if (SCM_EOF_VAL == form) + break; + last = scm_eval_x (form); + } + + } + + 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; + + scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */ + + { + SCM str_answer; + + str_answer = scm_strprint_obj (last); + *result = (char *)malloc (1 + SCM_LENGTH (str_answer)); + if (!*result) + stat = scm_boot_emem; + else + { + memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer)); + (*result)[SCM_LENGTH (str_answer)] = 0; + stat = scm_boot_ok; + } + } + } + else + { + /* This is reached if an unhandled throw terminated Scheme. + * Such an occurence should be extremely unlikely -- it indicates + * a programming error in the boot code. + * + * Details of the bogus exception are stored in scm_exitval even + * though that isn't currently reflected in the return value. + * !!! + */ + + scm_restore_signals (); + /* This tick gives any pending + * asyncs a chance to run. This must be done after + * the call to scm_restore_signals. + * + * Note that an unhandled exception during signal handling + * will put as back at the call to scm_restore_signals immediately + * preceeding. A sufficiently bogus signal handler could + * conceivably cause an infinite loop here. + */ + SCM_ASYNC_TICK; + + scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */ + + { + SCM str_answer; + + str_answer = scm_strprint_obj (scm_exitval); + *result = (char *)malloc (1 + SCM_LENGTH (str_answer)); + if (!*result) + stat = scm_boot_emem; + else + { + memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer)); + (*result)[SCM_LENGTH (str_answer)] = 0; + stat = scm_boot_error; + } + } + } + } + + scm_block_gc = 1; + live = 0; + return stat; +} diff --git a/libguile/init.h b/libguile/init.h new file mode 100644 index 000000000..a20262104 --- /dev/null +++ b/libguile/init.h @@ -0,0 +1,75 @@ +/* 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 "__scm.h" + + + +enum scm_boot_status +{ + scm_boot_ok = 0, + scm_boot_error, + scm_boot_emem, + scm_boot_ereenter +}; + + + +#ifdef __STDC__ +extern void scm_start_stack (void * base, FILE * in, FILE * out, FILE * err); +extern void scm_restart_stack (void * base); + +#else /* STDC */ +extern void scm_start_stack (); +extern void scm_restart_stack (); + +#endif /* STDC */ + + + + + +#endif /* INITH */ diff --git a/libguile/ioext.c b/libguile/ioext.c new file mode 100644 index 000000000..d51b9a09d --- /dev/null +++ b/libguile/ioext.c @@ -0,0 +1,535 @@ +/* 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 <unistd.h> +#include "fd.h" +#include "_scm.h" + + + +SCM_PROC (s_sys_ftell, "%ftell", 1, 0, 0, scm_sys_ftell); +#ifdef __STDC__ +SCM +scm_sys_ftell (SCM port) +#else +SCM +scm_sys_ftell (port) + SCM port; +#endif +{ + 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) + return SCM_BOOL_F; + if (pos > 0 && SCM_CRDYP (port)) + pos--; + return SCM_MAKINUM (pos); +} + + + +SCM_PROC (s_sys_fseek, "%fseek", 3, 0, 0, scm_sys_fseek); +#ifdef __STDC__ +SCM +scm_sys_fseek (SCM port, SCM offset, SCM whence) +#else +SCM +scm_sys_fseek (port, offset, whence) + SCM port; + SCM offset; + SCM whence; +#endif +{ + int rv; + SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fseek); + SCM_ASSERT (SCM_INUMP (offset), offset, 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), SCM_INUM (offset), SCM_INUM (whence)); + return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; +} + + + +SCM_PROC (s_sys_freopen, "%freopen", 3, 0, 0, scm_sys_freopen); +#ifdef __STDC__ +SCM +scm_sys_freopen (SCM filename, SCM modes, SCM port) +#else +SCM +scm_sys_freopen (filename, modes, port) + SCM filename; + SCM modes; + SCM port; +#endif +{ + 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_CAR (p) &= ~SCM_OPN; + scm_remove_from_port_table (p); + } + else + { + SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes)); + SCM_SETSTREAM (port, (SCM)f); + if (SCM_BUF0 & (SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes)))) + scm_setbuf0 (port); + } + SCM_ALLOW_INTS; + return port; +} + + + +SCM_PROC (s_sys_duplicate_port, "%duplicate-port", 2, 0, 0, scm_sys_duplicate_port); +#ifdef __STDC__ +SCM +scm_sys_duplicate_port (SCM oldpt, SCM modes) +#else +SCM +scm_sys_duplicate_port (oldpt, modes) + SCM oldpt; + SCM modes; +#endif +{ + 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_ALLOW_INTS; + return SCM_BOOL_F; + }; + SCM_SYSCALL (newfd = dup (oldfd)); + if (newfd == -1) + { + SCM_ALLOW_INTS; + return SCM_BOOL_F; + }; + f = fdopen (newfd, SCM_CHARS (modes)); + if (!f) + { + SCM_SYSCALL (close (newfd)); + SCM_ALLOW_INTS; + return SCM_BOOL_F; + } + { + struct scm_port_table * pt; + pt = scm_add_to_port_table (newpt); + SCM_SETPTAB_ENTRY (newpt, pt); + if (SCM_BUF0 & (SCM_CAR (newpt) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes)))) + 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); +#ifdef __STDC__ +SCM +scm_sys_redirect_port (SCM into_pt, SCM from_pt) +#else +SCM +scm_sys_redirect_port (into_pt, from_pt) + SCM into_pt; + SCM from_pt; +#endif +{ + 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)); + newfd = fileno ((FILE *)SCM_STREAM (from_pt)); + if (oldfd == -1 || newfd == -1) + ans = -1; + else + SCM_SYSCALL (ans = dup2 (oldfd, newfd)); + SCM_ALLOW_INTS; + return (ans == -1) ? SCM_MAKINUM (errno) : SCM_BOOL_T; +} + +SCM_PROC (s_sys_fileno, "%fileno", 1, 0, 0, scm_sys_fileno); +#ifdef __STDC__ +SCM +scm_sys_fileno (SCM port) +#else +SCM +scm_sys_fileno (port) + SCM port; +#endif +{ + int fd; + SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fileno); + fd = fileno ((FILE *)SCM_STREAM (port)); + return (fd == -1) ? SCM_BOOL_F : SCM_MAKINUM (fd); +} + + +SCM_PROC (s_sys_soft_fileno, "%soft-fileno", 1, 0, 0, scm_sys_soft_fileno); +#ifdef __STDC__ +SCM +scm_sys_soft_fileno (SCM port) +#else +SCM +scm_sys_soft_fileno (port) + SCM port; +#endif +{ + int fd; + SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_sys_fileno); + + if (!SCM_OPFPORTP (port)) + return SCM_BOOL_F; + + fd = fileno ((FILE *)SCM_STREAM (port)); + return (fd == -1) ? SCM_BOOL_F : SCM_MAKINUM (fd); +} + + + +SCM_PROC (s_sys_isatty, "%isatty?", 1, 0, 0, scm_sys_isatty_p); +#ifdef __STDC__ +SCM +scm_sys_isatty_p (SCM port) +#else +SCM +scm_sys_isatty_p (port) + SCM port; +#endif +{ + 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) + return SCM_MAKINUM (errno); + else + { + rv = isatty (rv); + return rv ? SCM_BOOL_T : SCM_BOOL_F; + } +} + + + +SCM_PROC (s_sys_fdopen, "%fdopen", 2, 0, 0, scm_sys_fdopen); +#ifdef __STDC__ +SCM +scm_sys_fdopen (SCM fdes, SCM modes) +#else +SCM +scm_sys_fdopen (fdes, modes) + SCM fdes; + SCM modes; +#endif +{ + FILE *f; + SCM port; + + 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_DEFER_INTS; + f = fdopen (SCM_INUM (fdes), SCM_CHARS (modes)); + if (f == NULL) + { + SCM_ALLOW_INTS; + return SCM_MAKINUM (errno); + } + SCM_NEWCELL (port); + SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes)); + SCM_SETSTREAM (port,(SCM)f); + scm_add_to_port_table (port); + SCM_ALLOW_INTS; + return port; +} + + + +/* Move a port's underlying file descriptor to a given value. + * Returns: #f for error. + * 0 if fdes is already the given value. + * 1 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); +#ifdef __STDC__ +SCM +scm_sys_primitive_move_to_fdes (SCM port, SCM fd) +#else +SCM +scm_sys_primitive_move_to_fdes (port, fd) + SCM port; + SCM fd; +#endif +{ + 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_MAKINUM (0); + } + scm_evict_ports (new_fd); + rv = dup2 (old_fd, new_fd); + if (rv == -1) + { + SCM_ALLOW_INTS; + return SCM_BOOL_F; + } + scm_setfileno (stream, new_fd); + SCM_SYSCALL (close (old_fd)); + SCM_ALLOW_INTS; + return SCM_MAKINUM (1); +} + + + +/* FIXME */ +#ifdef __STDC__ +void +scm_setfileno (FILE *fs, int fd) +#else +void +scm_setfileno (fs, fd) + FILE *fs; + int fd; +#endif +{ +#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. + */ +#ifdef __STDC__ +void +scm_evict_ports (int fd) +#else +void +scm_evict_ports (fd) + int fd; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_fdes_to_ports (SCM fd) +#else +SCM +scm_fdes_to_ports (fd) + SCM fd; +#endif +{ + 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; +} + +#ifdef __STDC__ +void +scm_init_ioext (void) +#else +void +scm_init_ioext () +#endif +{ + /* 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)); + + /* 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)); + + /* 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 new file mode 100644 index 000000000..b7a30e2c0 --- /dev/null +++ b/libguile/ioext.h @@ -0,0 +1,87 @@ +/* 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 "__scm.h" + + + + + +#ifdef __STDC__ +extern SCM scm_sys_ftell (SCM port); +extern SCM scm_sys_fseek (SCM port, SCM offset, SCM whence); +extern SCM scm_sys_freopen (SCM filename, SCM modes, SCM port); +extern SCM scm_sys_duplicate_port (SCM oldpt, SCM modes); +extern SCM scm_sys_redirect_port (SCM into_pt, SCM from_pt); +extern SCM scm_sys_fileno (SCM port); +extern SCM scm_sys_isatty (SCM port); +extern SCM scm_sys_fdopen (SCM fdes, SCM modes); +extern SCM scm_sys_primitive_move_to_fdes (SCM port, SCM fd); +extern void scm_setfileno (FILE *fs, int fd); +extern void scm_evict_ports (int fd); +extern SCM scm_fdes_to_ports (SCM fd); +extern void scm_init_ioext (void); + +#else /* STDC */ +extern SCM scm_sys_ftell (); +extern SCM scm_sys_fseek (); +extern SCM scm_sys_freopen (); +extern SCM scm_sys_duplicate_port (); +extern SCM scm_sys_redirect_port (); +extern SCM scm_sys_fileno (); +extern SCM scm_sys_isatty (); +extern SCM scm_sys_fdopen (); +extern SCM scm_sys_primitive_move_to_fdes (); +extern void scm_setfileno (); +extern void scm_evict_ports (); +extern SCM scm_fdes_to_ports (); +extern void scm_init_ioext (); + +#endif /* STDC */ + + + +#endif /* IOEXTH */ diff --git a/libguile/kw.c b/libguile/kw.c new file mode 100644 index 000000000..e559ef3ea --- /dev/null +++ b/libguile/kw.c @@ -0,0 +1,164 @@ +/* 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" + + + +#ifdef __STDC__ +static scm_sizet +free_kw (SCM obj) +#else +static scm_sizet +free_kw (obj) + SCM obj; +#endif +{ + return 0; +} + +#ifdef __STDC__ +static int +prin_kw (SCM exp, SCM port, int writing) +#else +static int +prin_kw (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_make_keyword_from_dash_symbol (SCM symbol) +#else +SCM +scm_make_keyword_from_dash_symbol (symbol) + SCM symbol; +#endif +{ + 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_CAR(kw) = (SCM)scm_tc16_kw; + SCM_CDR(kw) = symbol; + scm_intern_symbol (scm_kw_obarray, symbol); + vcell = scm_sym2ovcell_soft (symbol, scm_kw_obarray); + SCM_CDR (vcell) = kw; + } + SCM_ALLOW_INTS; + return SCM_CDR (vcell); +} + +SCM_PROC(s_keyword_p, "keyword?", 1, 0, 0, scm_keyword_p); +#ifdef __STDC__ +SCM +scm_keyword_p (SCM obj) +#else +SCM +scm_keyword_p (obj) + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_keyword_dash_symbol (SCM kw) +#else +SCM +scm_keyword_dash_symbol (kw) + SCM kw; +#endif +{ + SCM_ASSERT (SCM_NIMP (kw) && SCM_KEYWORDP (kw), kw, SCM_ARG1, s_keyword_dash_symbol); + return SCM_CDR (kw); +} + + + + +#ifdef __STDC__ +void +scm_init_kw (void) +#else +void +scm_init_kw () +#endif +{ + 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 new file mode 100644 index 000000000..c84899cff --- /dev/null +++ b/libguile/kw.h @@ -0,0 +1,70 @@ +/* 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 "__scm.h" + + + +extern int scm_tc16_kw; +#define SCM_KEYWORDP(X) (SCM_CAR(X) == scm_tc16_kw) +#define SCM_KEYWORDSYM(X) (SCM_CDR(X)) + + + +#ifdef __STDC__ +extern SCM scm_make_keyword_from_dash_symbol (SCM symbol); +extern SCM scm_keyword_p (SCM obj); +extern SCM scm_keyword_dash_symbol (SCM kw); +extern void scm_init_kw (void); + +#else /* STDC */ +extern SCM scm_make_keyword_from_dash_symbol (); +extern SCM scm_keyword_p (); +extern SCM scm_keyword_dash_symbol (); +extern void scm_init_kw (); + +#endif /* STDC */ +#endif /* KWH */ diff --git a/libguile/libguile.h b/libguile/libguile.h new file mode 100644 index 000000000..ea18a23db --- /dev/null +++ b/libguile/libguile.h @@ -0,0 +1,142 @@ +#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. + */ + + + + +#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 "__scm.h" + +#include "smob.h" + + + +#include "alist.h" +#include "append.h" +#include "arbiters.h" +#include "async.h" +#include "boolean.h" +#include "chars.h" +#include "continuations.h" +#include "dynwind.h" +#include "eq.h" +#include "error.h" +#include "eval.h" +#include "extchrs.h" +#include "fdsocket.h" +#include "feature.h" +#include "files.h" +#include "filesys.h" +#include "fports.h" +#include "gc.h" +#include "genio.h" +#include "gsubr.h" +#include "hash.h" +#include "hashtab.h" +#include "init.h" +#include "ioext.h" +#include "kw.h" +#include "libguile.h" +#include "list.h" +#include "load.h" +#include "mallocs.h" +#include "markers.h" +#include "marksweep.h" +#include "mbstrings.h" +#include "numbers.h" +#include "pairs.h" +#include "params.h" +#include "ports.h" +#include "posix.h" +#include "print.h" +#include "procprop.h" +#include "procs.h" +#include "ramap.h" +#include "read.h" +#include "root.h" +#include "scmsigs.h" +#include "sequences.h" +#include "simpos.h" +#include "socket.h" +#include "stackchk.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 "tags.h" +#include "throw.h" +#include "unif.h" +#include "variable.h" +#include "vectors.h" +#include "vports.h" +#include "weaks.h" + + + + +#ifdef __STDC__ + +#else /* STDC */ + +#endif /* STDC */ + + +#endif /* LIBGUILEH */ diff --git a/libguile/list.c b/libguile/list.c new file mode 100644 index 000000000..15c20fd32 --- /dev/null +++ b/libguile/list.c @@ -0,0 +1,791 @@ +/* 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" + +#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 + + + + +#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_CDR (*pos); + elt = va_arg (foo, SCM); + } + return answer; +} + + +SCM_PROC(s_list, "list", 0, 0, 1, scm_list); +#ifdef __STDC__ +SCM +scm_list(SCM objs) +#else +SCM +scm_list(objs) + SCM objs; +#endif +{ + return objs; +} + + + + + +SCM_PROC(s_null_p, "null?", 1, 0, 0, scm_null_p); +#ifdef __STDC__ +SCM +scm_null_p(SCM x) +#else +SCM +scm_null_p(x) + SCM x; +#endif +{ + return SCM_NULLP(x) ? SCM_BOOL_T : SCM_BOOL_F; +} + +SCM_PROC(s_list_p, "list?", 1, 0, 0, scm_list_p); +#ifdef __STDC__ +SCM +scm_list_p(SCM x) +#else +SCM +scm_list_p(x) + SCM x; +#endif +{ + if (scm_ilength(x)<0) + return SCM_BOOL_F; + else + return SCM_BOOL_T; +} + + +#ifdef __STDC__ +long +scm_ilength(SCM sx) +#else +long +scm_ilength(sx) + SCM sx; +#endif +{ + register long i = 0; + register SCM x = sx; + do { + if SCM_IMP(x) return SCM_NULLP(x) ? i : -1; + if SCM_NCONSP(x) return -1; + x = SCM_CDR(x); + i++; + if SCM_IMP(x) return SCM_NULLP(x) ? i : -1; + if SCM_NCONSP(x) return -1; + x = SCM_CDR(x); + i++; + sx = SCM_CDR(sx); + } + while (x != sx); + return -1; +} + +SCM_PROC(s_list_length, "list-length", 1, 0, 0, scm_list_length); +#ifdef __STDC__ +SCM +scm_list_length(SCM x) +#else +SCM +scm_list_length(x) + SCM x; +#endif +{ + int i; + i = scm_ilength(x); + SCM_ASSERT(i >= 0, x, SCM_ARG1, s_list_length); + return SCM_MAKINUM (i); +} + + + + +SCM_PROC (s_list_append, "list-append", 0, 0, 1, scm_list_append); +#ifdef __STDC__ +SCM +scm_list_append(SCM args) +#else +SCM +scm_list_append(args) + SCM args; +#endif +{ + 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_CDR(*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); +#ifdef __STDC__ +SCM +scm_list_append_x(SCM args) +#else +SCM +scm_list_append_x(args) + SCM args; +#endif +{ + 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_CDR(scm_last_pair(arg)) = scm_list_append_x(args); + return arg; +} + + + + + +SCM_PROC (s_list_reverse, "list-reverse", 1, 0, 0, scm_list_reverse); +#ifdef __STDC__ +SCM +scm_list_reverse(SCM lst) +#else +SCM +scm_list_reverse(lst) + SCM lst; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_list_reverse_x (SCM lst, SCM newtail) +#else +SCM +scm_list_reverse_x (lst, newtail) + SCM lst; + SCM newtail; +#endif +{ + 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; +} + + + + + +SCM_PROC(s_list_ref, "list-ref", 2, 0, 0, scm_list_ref); +#ifdef __STDC__ +SCM +scm_list_ref(SCM lst, SCM k) +#else +SCM +scm_list_ref(lst, k) + SCM lst; + SCM k; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_list_set_x(SCM lst, SCM k, SCM val) +#else +SCM +scm_list_set_x(lst, k, val) + SCM lst; + SCM k; + SCM val; +#endif +{ + 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_CAR (lst) = val; + return val; +} + + + +SCM_PROC(s_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x); +#ifdef __STDC__ +SCM +scm_list_cdr_set_x(SCM lst, SCM k, SCM val) +#else +SCM +scm_list_cdr_set_x(lst, k, val) + SCM lst; + SCM k; + SCM val; +#endif +{ + 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; +} + + + + + + +SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair); +#ifdef __STDC__ +SCM +scm_last_pair(SCM sx) +#else +SCM +scm_last_pair(sx) + SCM sx; +#endif +{ + 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); + } +} + +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); +#ifdef __STDC__ +SCM +scm_list_tail(SCM lst, SCM k) +#else +SCM +scm_list_tail(lst, k) + SCM lst; + SCM k; +#endif +{ + 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_head, "list-head", 2, 0, 0, scm_list_head); +#ifdef __STDC__ +SCM +scm_list_head(SCM lst, SCM k) +#else +SCM +scm_list_head(lst, k) + SCM lst; + SCM k; +#endif +{ + 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_CDR (*pos); + lst = SCM_CDR(lst); + } + return answer; +} + + + + +#ifdef __STDC__ +static void +sloppy_mem_check (SCM obj, char * where, char * why) +#else +static void +sloppy_mem_check (obj, where, why) + SCM obj; + char * where; + char * why; +#endif +{ + SCM_ASSERT ((scm_ilength (obj) >= 0), obj, where, why); +} + + +SCM_PROC (s_sloppy_memq, "sloppy-memq", 2, 0, 0, scm_sloppy_memq); +#ifdef __STDC__ +SCM +scm_sloppy_memq(SCM x, SCM lst) +#else +SCM +scm_sloppy_memq(x, lst) + SCM x; + SCM lst; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_sloppy_memv(SCM x, SCM lst) +#else +SCM +scm_sloppy_memv(x, lst) + SCM x; + SCM lst; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_sloppy_member (SCM x, SCM lst) +#else +SCM +scm_sloppy_member (x, lst) + SCM x; + SCM lst; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_memq(SCM x, SCM lst) +#else +SCM +scm_memq(x, lst) + SCM x; + SCM lst; +#endif +{ + SCM answer; + answer = scm_sloppy_memq (x, lst); + sloppy_mem_check (answer, (char *)SCM_ARG2, s_memq); + return answer; +} + + + +SCM_PROC(s_memv, "memv", 2, 0, 0, scm_memv); +#ifdef __STDC__ +SCM +scm_memv(SCM x, SCM lst) +#else +SCM +scm_memv(x, lst) + SCM x; + SCM lst; +#endif +{ + SCM answer; + answer = scm_sloppy_memv (x, lst); + sloppy_mem_check (answer, (char *)SCM_ARG2, s_memv); + return answer; +} + + +SCM_PROC(s_member, "member", 2, 0, 0, scm_member); +#ifdef __STDC__ +SCM +scm_member(SCM x, SCM lst) +#else +SCM +scm_member(x, lst) + SCM x; + SCM lst; +#endif +{ + SCM answer; + answer = scm_sloppy_member (x, lst); + sloppy_mem_check (answer, (char *)SCM_ARG2, s_member); + return answer; +} + + + + +SCM_PROC(s_delq_x, "delq!", 2, 0, 0, scm_delq_x); +#ifdef __STDC__ +SCM +scm_delq_x (SCM item, SCM lst) +#else +SCM +scm_delq_x (item, lst) + SCM item; + SCM lst; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_delv_x (SCM item, SCM lst) +#else +SCM +scm_delv_x (item, lst) + SCM item; + SCM lst; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_delete_x (SCM item, SCM lst) +#else +SCM +scm_delete_x (item, lst) + SCM item; + SCM lst; +#endif +{ + 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_list_copy, "list-copy", 1, 0, 0, scm_list_copy); +#ifdef __STDC__ +SCM +scm_list_copy (SCM lst) +#else +SCM +scm_list_copy (lst) + SCM lst; +#endif +{ + 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_CDR (c); + from_here = SCM_CDR (from_here); + } + return newlst; +} + + + +SCM_PROC (s_delq, "delq", 2, 0, 0, scm_delq); +#ifdef __STDC__ +SCM +scm_delq (SCM item, SCM lst) +#else +SCM +scm_delq (item, lst) + SCM item; + SCM lst; +#endif +{ + SCM copy; + + copy = scm_list_copy (lst); + return scm_delq_x (item, copy); +} + +SCM_PROC (s_delv, "delv", 2, 0, 0, scm_delv); +#ifdef __STDC__ +SCM +scm_delv (SCM item, SCM lst) +#else +SCM +scm_delv (item, lst) + SCM item; + SCM lst; +#endif +{ + SCM copy; + + copy = scm_list_copy (lst); + return scm_delv_x (item, copy); +} + +SCM_PROC (s_delete, "delete", 2, 0, 0, scm_delete); +#ifdef __STDC__ +SCM +scm_delete (SCM item, SCM lst) +#else +SCM +scm_delete (item, lst) + SCM item; + SCM lst; +#endif +{ + SCM copy; + + copy = scm_list_copy (lst); + return scm_delete_x (item, copy); +} + + + + +#ifdef __STDC__ +void +scm_init_list (void) +#else +void +scm_init_list () +#endif +{ +#include "list.x" +} + diff --git a/libguile/list.h b/libguile/list.h new file mode 100644 index 000000000..ab0555540 --- /dev/null +++ b/libguile/list.h @@ -0,0 +1,126 @@ +/* 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 "__scm.h" + + + + + + +#ifdef __STDC__ +extern SCM scm_listify (SCM elt, ...); +extern SCM scm_list(SCM objs); +extern SCM scm_null_p(SCM x); +extern SCM scm_list_p(SCM x); +extern long scm_ilength(SCM sx); +extern SCM scm_list_length(SCM x); +extern SCM scm_list_append(SCM args); +extern SCM scm_list_append_x(SCM args); +extern SCM scm_list_reverse(SCM lst); +extern SCM scm_list_reverse_x (SCM lst, SCM newtail); +extern SCM scm_list_ref(SCM lst, SCM k); +extern SCM scm_list_set_x(SCM lst, SCM k, SCM val); +extern SCM scm_list_cdr_ref(SCM lst, SCM k); +extern SCM scm_list_cdr_set_x(SCM lst, SCM k, SCM val); +extern SCM scm_last_pair(SCM sx); +extern SCM scm_list_tail(SCM lst, SCM k); +extern SCM scm_sloppy_memq(SCM x, SCM lst); +extern SCM scm_sloppy_memv(SCM x, SCM lst); +extern SCM scm_sloppy_member (SCM x, SCM lst); +extern SCM scm_memq(SCM x, SCM lst); +extern SCM scm_memv(SCM x, SCM lst); +extern SCM scm_member(SCM x, SCM lst); +extern SCM scm_delq_x (SCM item, SCM lst); +extern SCM scm_delv_x (SCM item, SCM lst); +extern SCM scm_delete_x (SCM item, SCM lst); +extern SCM scm_list_copy (SCM lst); +extern SCM scm_delq (SCM item, SCM lst); +extern SCM scm_delv (SCM item, SCM lst); +extern SCM scm_delete (SCM item, SCM lst); +extern void scm_init_list (void); + +#else /* STDC */ +extern SCM scm_listify (); +extern SCM scm_list(); +extern SCM scm_null_p(); +extern SCM scm_list_p(); +extern long scm_ilength(); +extern SCM scm_list_length(); +extern SCM scm_list_append(); +extern SCM scm_list_append_x(); +extern SCM scm_list_reverse(); +extern SCM scm_list_reverse_x (); +extern SCM scm_list_ref(); +extern SCM scm_list_set_x(); +extern SCM scm_list_cdr_ref(); +extern SCM scm_list_cdr_set_x(); +extern SCM scm_last_pair(); +extern SCM scm_list_tail(); +extern SCM scm_sloppy_memq(); +extern SCM scm_sloppy_memv(); +extern SCM scm_sloppy_member (); +extern SCM scm_memq(); +extern SCM scm_memv(); +extern SCM scm_member(); +extern SCM scm_delq_x (); +extern SCM scm_delv_x (); +extern SCM scm_delete_x (); +extern SCM scm_list_copy (); +extern SCM scm_delq (); +extern SCM scm_delv (); +extern SCM scm_delete (); +extern void scm_init_list (); + +#endif /* STDC */ + + + + + + + +#endif /* LISTH */ diff --git a/libguile/load.c b/libguile/load.c new file mode 100644 index 000000000..b2a54d79a --- /dev/null +++ b/libguile/load.c @@ -0,0 +1,91 @@ +/* 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" + + + +SCM_PROC(s_sys_try_load, "%try-load", 1, 2, 0, scm_sys_try_load); +#ifdef __STDC__ +SCM +scm_sys_try_load (SCM filename, SCM case_insensative_p, SCM sharp) +#else +SCM +scm_sys_try_load (filename, case_insensative_p, sharp) + SCM filename; + SCM case_insensative_p; + SCM sharp; +#endif +{ + SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_sys_try_load); + { + SCM form, port; + port = scm_open_file (filename, + scm_makfromstr ("r", (scm_sizet) sizeof (char), 0)); + if (SCM_FALSEP (port)) + return SCM_BOOL_F; + while (1) + { + form = scm_read (port, case_insensative_p, sharp); + if (SCM_EOF_VAL == form) + break; + scm_eval_x (form); + } + scm_close_port (port); + } + return SCM_BOOL_T; +} + + + +#ifdef __STDC__ +void +scm_init_load (void) +#else +void +scm_init_load () +#endif +{ +#include "load.x" +} + diff --git a/libguile/load.h b/libguile/load.h new file mode 100644 index 000000000..eab41b173 --- /dev/null +++ b/libguile/load.h @@ -0,0 +1,62 @@ +/* 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. + */ + + + + +#ifdef __STDC__ +extern SCM scm_sys_try_load (SCM filename, SCM casep, SCM sharp); +extern void scm_init_load (void); + +#else /* STDC */ +extern SCM scm_sys_try_load (); +extern void scm_init_load (); + +#endif /* STDC */ + + + + +#endif /* LOADH */ diff --git a/libguile/mallocs.c b/libguile/mallocs.c new file mode 100644 index 000000000..27f1a791c --- /dev/null +++ b/libguile/mallocs.c @@ -0,0 +1,113 @@ +/* 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 "mallocs.h" +#ifdef HAVE_MALLOC_H +#include "malloc.h" +#endif +#ifdef HAVE_UNISTD_H +#include "unistd.h" +#endif + + + + + +#ifdef __STDC__ +static scm_sizet +fmalloc(SCM ptr) +#else +static scm_sizet +fmalloc(ptr) + SCM ptr; +#endif +{ + if (SCM_MALLOCDATA (ptr)) + free (SCM_MALLOCDATA (ptr)); + return 0; +} + +#ifdef __STDC__ +static int +prinmalloc (SCM exp, SCM port, int writing) +#else +static int +prinmalloc (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + 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}; + + + +#ifdef __STDC__ +SCM +scm_malloc_obj (scm_sizet n) +#else +SCM +scm_malloc_obj (n) + scm_sizet n; +#endif +{ + 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_CDR (answer) = mem; + SCM_CAR (answer) = scm_tc16_malloc; + SCM_ALLOW_INTS; + return answer; +} + + + +#ifdef __STDC__ +void +scm_init_mallocs (void) +#else +void +scm_init_mallocs () +#endif +{ + scm_tc16_malloc = scm_newsmob (&mallocsmob); +} + diff --git a/libguile/mallocs.h b/libguile/mallocs.h new file mode 100644 index 000000000..779c25d18 --- /dev/null +++ b/libguile/mallocs.h @@ -0,0 +1,66 @@ +/* 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. + */ + + +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)) + + +#ifdef __STDC__ +extern SCM scm_malloc_obj (scm_sizet n); +extern void scm_init_mallocs (void); + +#else /* STDC */ +extern SCM scm_malloc_obj (); +extern void scm_init_mallocs (); + +#endif /* STDC */ + + + +#endif /* MALLOCSH */ diff --git a/libguile/markers.c b/libguile/markers.c new file mode 100644 index 000000000..d6a3c8288 --- /dev/null +++ b/libguile/markers.c @@ -0,0 +1,92 @@ +/* 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" + + + +/* {GC marking} + */ + +#ifdef __STDC__ +SCM +scm_mark0 (SCM ptr) +#else +SCM +scm_mark0 (ptr) + SCM ptr; +#endif +{ + SCM_SETGC8MARK (ptr); + return SCM_BOOL_F; +} + + +#ifdef __STDC__ +SCM +scm_markcdr (SCM ptr) +#else +SCM +scm_markcdr (ptr) + SCM ptr; +#endif +{ + if (SCM_GC8MARKP (ptr)) + return SCM_BOOL_F; + SCM_SETGC8MARK (ptr); + return SCM_CDR (ptr); +} + +#ifdef __STDC__ +scm_sizet +scm_free0 (SCM ptr) +#else +scm_sizet +scm_free0 (ptr) + SCM ptr; +#endif +{ + return 0; +} + + diff --git a/libguile/markers.h b/libguile/markers.h new file mode 100644 index 000000000..0debbc4ac --- /dev/null +++ b/libguile/markers.h @@ -0,0 +1,68 @@ +/* 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 "__scm.h" + + + + + + +#ifdef __STDC__ +extern SCM scm_mark0 (SCM ptr); +extern SCM scm_markcdr (SCM ptr); +extern scm_sizet scm_free0 (SCM ptr); + +#else /* STDC */ +extern SCM scm_mark0 (); +extern SCM scm_markcdr (); +extern scm_sizet scm_free0 (); + +#endif /* STDC */ + + + +#endif /* MARKERSH */ diff --git a/libguile/mbstrings.c b/libguile/mbstrings.c new file mode 100644 index 000000000..4d8bb1834 --- /dev/null +++ b/libguile/mbstrings.c @@ -0,0 +1,568 @@ + + +/* 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" + + + +SCM_PROC(s_multi_byte_string_p, "multi-byte-string?", 1, 0, 0, scm_multi_byte_string_p); +#ifdef __STDC__ +SCM +scm_multi_byte_string_p (SCM obj) +#else +SCM +scm_multi_byte_string_p (obj) + SCM obj; +#endif +{ + return (SCM_MB_STRINGP (obj) + ? SCM_BOOL_T + : SCM_BOOL_F); +} + + +#ifdef __STDC__ +SCM +scm_regular_string_p (SCM obj) +#else +SCM +scm_regular_string_p (obj) + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_multi_byte_string (SCM chrs) +#else +SCM +scm_multi_byte_string (chrs) + SCM chrs; +#endif +{ + 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; +} + +#ifdef __STDC__ +int +scm_mb_ilength (unsigned char * data, int size) +#else +int +scm_mb_ilength (data, size) + unsigned char * data; + int size; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_multi_byte_string_length (SCM str) +#else +SCM +scm_multi_byte_string_length (str) + SCM str; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_symbol_multi_byte_p (SCM symbol) +#else +SCM +scm_symbol_multi_byte_p (symbol) + SCM symbol; +#endif +{ + return SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP(symbol); +} + +SCM_PROC(s_set_symbol_multi_byte_x, "set-symbol-multi-byte!", 2, 0, 0, scm_set_symbol_multi_byte_x); +#ifdef __STDC__ +SCM +scm_set_symbol_multi_byte_x (SCM symbol, SCM val) +#else +SCM +scm_set_symbol_multi_byte_x (symbol, val) + SCM symbol; + SCM val; +#endif +{ + if (SCM_TYP7 (symbol) == scm_tc7_msymbol) + { + SCM_SYMBOL_MULTI_BYTE_SCM_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); +#ifdef __STDC__ +SCM +scm_regular_port_p (SCM p) +#else +SCM +scm_regular_port_p (p) + SCM p; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_regular_port_x (SCM p) +#else +SCM +scm_regular_port_x (p) + SCM p; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_multi_byte_port_p (SCM p) +#else +SCM +scm_multi_byte_port_p (p) + SCM p; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_multi_byte_port_x (SCM p) +#else +SCM +scm_multi_byte_port_x (p) + SCM p; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_wide_character_port_p (SCM p) +#else +SCM +scm_wide_character_port_p (p) + SCM p; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_wide_character_port_x (SCM p) +#else +SCM +scm_wide_character_port_x (p) + SCM p; +#endif +{ + SCM_PORT_REPRESENTATION(p) = scm_wchar_port; + return SCM_UNSPECIFIED; +} + + + + + +#ifdef __STDC__ +void +scm_put_wchar (int c, SCM port, int writing) +#else +void +scm_put_wchar (c, port, writing) + int c; + SCM port; + int writing; +#endif +{ + 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; + } + } +} + + + + + +#ifdef __STDC__ +void +scm_print_mb_string (SCM exp, SCM port, int writing) +#else +void +scm_print_mb_string (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + 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); +} + + +#ifdef __STDC__ +void +scm_print_mb_symbol (SCM exp, SCM port) +#else +void +scm_print_mb_symbol (exp, port) + SCM exp; + SCM port; +#endif +{ + int pos; + int end; + int len; + char * str; + int weird; + int maybe_weird; + int mw_pos; + int inc; + 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); +} + + + + +#ifdef __STDC__ +void +scm_init_mbstrings (void) +#else +void +scm_init_mbstrings () +#endif +{ +#include "mbstrings.x" +} + diff --git a/libguile/mbstrings.h b/libguile/mbstrings.h new file mode 100644 index 000000000..e1d3ef0cb --- /dev/null +++ b/libguile/mbstrings.h @@ -0,0 +1,100 @@ +/* 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 "__scm.h" +#include "symbols.h" + + +#define SCM_MB_STRINGP(x) ( (SCM_TYP7(x)==scm_tc7_mb_string) \ + || ( (SCM_TYP7(x) == scm_tc7_msymbol) \ + && (SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (x) != SCM_BOOL_F))) +#define SCM_REGULAR_STRINGP(x) (SCM_TYP7D(x)==scm_tc7_string) + + + + +#ifdef __STDC__ +extern SCM scm_multi_byte_string_p (SCM obj); +extern SCM scm_regular_string_p (SCM obj); +extern SCM scm_multi_byte_string (SCM chrs); +extern int scm_mb_ilength (unsigned char * data, int size); +extern SCM scm_multi_byte_string_length (SCM str); +extern SCM scm_symbol_multi_byte_p (SCM symbol); +extern SCM scm_set_symbol_multi_byte_x (SCM symbol, SCM val); +extern SCM scm_regular_port_p (SCM p); +extern SCM scm_regular_port_x (SCM p); +extern SCM scm_multi_byte_port_p (SCM p); +extern SCM scm_multi_byte_port_x (SCM p); +extern SCM scm_wide_character_port_p (SCM p); +extern SCM scm_wide_character_port_x (SCM p); +extern void scm_put_wchar (int c, SCM port, int writing); +extern void scm_print_mb_string (SCM exp, SCM port, int writing); +extern void scm_print_mb_symbol (SCM exp, SCM port); +extern void scm_init_mbstrings (void); + +#else /* STDC */ +extern SCM scm_multi_byte_string_p (); +extern SCM scm_regular_string_p (); +extern SCM scm_multi_byte_string (); +extern int scm_mb_ilength (); +extern SCM scm_multi_byte_string_length (); +extern SCM scm_symbol_multi_byte_p (); +extern SCM scm_set_symbol_multi_byte_x (); +extern SCM scm_regular_port_p (); +extern SCM scm_regular_port_x (); +extern SCM scm_multi_byte_port_p (); +extern SCM scm_multi_byte_port_x (); +extern SCM scm_wide_character_port_p (); +extern SCM scm_wide_character_port_x (); +extern void scm_put_wchar (); +extern void scm_print_mb_string (); +extern void scm_print_mb_symbol (); +extern void scm_init_mbstrings (); + +#endif /* STDC */ + + +#endif /* MBSTRINGSH */ diff --git a/libguile/numbers.c b/libguile/numbers.c new file mode 100644 index 000000000..b572ed79f --- /dev/null +++ b/libguile/numbers.c @@ -0,0 +1,4101 @@ +/* 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" + + + +#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); +#ifdef __STDC__ +SCM +scm_exact_p(SCM x) +#else +SCM +scm_exact_p(x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_odd_p(SCM n) +#else +SCM +scm_odd_p(n) + SCM n; +#endif +{ +#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); +#ifdef __STDC__ +SCM +scm_even_p(SCM n) +#else +SCM +scm_even_p(n) + SCM n; +#endif +{ +#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); +#ifdef __STDC__ +SCM +scm_abs(SCM x) +#else +SCM +scm_abs(x) + SCM x; +#endif +{ +#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_POSSCM_FIXABLE(x)) +#ifdef SCM_BIGDIG + return scm_long2big(x); +#else + scm_wta(SCM_MAKINUM(-x), (char *)SCM_OVSCM_FLOW, s_abs); +#endif + return SCM_MAKINUM(x); +} + +SCM_PROC(s_quotient, "quotient", 2, 0, 0, scm_quotient); +#ifdef __STDC__ +SCM +scm_quotient(SCM x, SCM y) +#else +SCM +scm_quotient(x, y) + SCM x; + SCM y; +#endif +{ + 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_wta(y, (char *)SCM_OVSCM_FLOW, 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_wta(x, (char *)SCM_OVSCM_FLOW, s_quotient); +#endif + return SCM_MAKINUM(z); +} + +SCM_PROC(s_remainder, "remainder", 2, 0, 0, scm_remainder); +#ifdef __STDC__ +SCM +scm_remainder(SCM x, SCM y) +#else +SCM +scm_remainder(x, y) + SCM x; + SCM y; +#endif +{ + 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_wta(y, (char *)SCM_OVSCM_FLOW, 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); +#ifdef __STDC__ +SCM +scm_modulo(SCM x, SCM y) +#else +SCM +scm_modulo(x, y) + SCM x; + SCM y; +#endif +{ + 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_wta(y, (char *)SCM_OVSCM_FLOW, 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); +#ifdef __STDC__ +SCM +scm_gcd(SCM x, SCM y) +#else +SCM +scm_gcd(x, y) + SCM x; + SCM y; +#endif +{ + 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_POSSCM_FIXABLE(u)) +#ifdef SCM_BIGDIG + return scm_long2big(u); +#else + scm_wta(x, (char *)SCM_OVSCM_FLOW, s_gcd); +#endif + return SCM_MAKINUM(u); +} + +SCM_PROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm); +#ifdef __STDC__ +SCM +scm_lcm(SCM n1, SCM n2) +#else +SCM +scm_lcm(n1, n2) + SCM n1; + SCM n2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_logand(SCM n1, SCM n2) +#else +SCM +scm_logand(n1, n2) + SCM n1; + SCM n2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_logior(SCM n1, SCM n2) +#else +SCM +scm_logior(n1, n2) + SCM n1; + SCM n2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_logxor(SCM n1, SCM n2) +#else +SCM +scm_logxor(n1, n2) + SCM n1; + SCM n2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_logtest(SCM n1, SCM n2) +#else +SCM +scm_logtest(n1, n2) + SCM n1; + SCM n2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_logbit_p(SCM n1, SCM n2) +#else +SCM +scm_logbit_p(n1, n2) + SCM n1; + SCM n2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_logand(SCM n1, SCM n2) +#else +SCM +scm_logand(n1, n2) + SCM n1; + SCM n2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_logior(SCM n1, SCM n2) +#else +SCM +scm_logior(n1, n2) + SCM n1; + SCM n2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_logxor(SCM n1, SCM n2) +#else +SCM +scm_logxor(n1, n2) + SCM n1; + SCM n2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_logtest(SCM n1, SCM n2) +#else +SCM +scm_logtest(n1, n2) + SCM n1; + SCM n2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_logbit_p(SCM n1, SCM n2) +#else +SCM +scm_logbit_p(n1, n2) + SCM n1; + SCM n2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_lognot(SCM n) +#else +SCM +scm_lognot(n) + SCM n; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_integer_expt(SCM z1, SCM z2) +#else +SCM +scm_integer_expt(z1, z2) + SCM z1; + SCM z2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_ash(SCM n, SCM cnt) +#else +SCM +scm_ash(n, cnt) + SCM n; + SCM cnt; +#endif +{ + 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_wta(n, (char *)SCM_OVSCM_FLOW, s_ash); + return res; +#endif +} + +SCM_PROC(s_bit_extract, "bit-extract", 3, 0, 0, scm_bit_extract); +#ifdef __STDC__ +SCM +scm_bit_extract(SCM n, SCM start, SCM end) +#else +SCM +scm_bit_extract(n, start, end) + SCM n; + SCM start; + SCM end; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_logcount (SCM n) +#else +SCM +scm_logcount(n) + SCM n; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_integer_length(SCM n) +#else +SCM +scm_integer_length(n) + SCM n; +#endif +{ + 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"; +#ifdef __STDC__ +SCM +scm_mkbig(scm_sizet nlen, int sign) +#else +SCM +scm_mkbig(nlen, sign) + scm_sizet nlen; + int sign; +#endif +{ + 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; +} + +#ifdef __STDC__ +SCM +scm_big2inum(SCM b, scm_sizet l) +#else +SCM +scm_big2inum(b, l) + SCM b; + scm_sizet l; +#endif +{ + 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_POSSCM_FIXABLE(num) return SCM_MAKINUM(num); + } + else if SCM_UNEGSCM_FIXABLE(num) return SCM_MAKINUM(-num); + return b; +} + + +char s_adjbig[] = "scm_adjbig"; +#ifdef __STDC__ +SCM +scm_adjbig(SCM b, scm_sizet nlen) +#else +SCM +scm_adjbig(b, nlen) + SCM b; + scm_sizet nlen; +#endif +{ + 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; +} + + +#ifdef __STDC__ +SCM +scm_normbig(SCM b) +#else +SCM +scm_normbig(b) + SCM b; +#endif +{ +#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); +} + + +#ifdef __STDC__ +SCM +scm_copybig(SCM b, int sign) +#else +SCM +scm_copybig(b, sign) + SCM b; + int sign; +#endif +{ + 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; +} + + +#ifdef __STDC__ +SCM +scm_long2big(long n) +#else +SCM +scm_long2big(n) + long n; +#endif +{ + 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 +#ifdef __STDC__ +SCM +scm_long_long2big(long_long n) +#else +SCM +scm_long_long2big(n) + long_long n; +#endif +{ + 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 + +#ifdef __STDC__ +SCM +scm_2ulong2big(unsigned long * np) +#else +SCM +scm_2ulong2big(np) + unsigned long * np; +#endif +{ + 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; +} + + +#ifdef __STDC__ +SCM +scm_ulong2big(unsigned long n) +#else +SCM +scm_ulong2big(n) + unsigned long n; +#endif +{ + 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; +} + + +#ifdef __STDC__ +int +scm_bigcomp(SCM x, SCM y) +#else +int +scm_bigcomp(x, y) + SCM x; + SCM y; +#endif +{ + 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 + +#ifdef __STDC__ +long +scm_pseudolong(long x) +#else +long +scm_pseudolong(x) + long x; +#endif +{ + 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 + +#ifdef __STDC__ +void +scm_longdigs(long x, SCM_BIGDIG digs[]) +#else +void +scm_longdigs(x, digs) + long x; + SCM_BIGDIG digs[]; +#endif +{ + scm_sizet i = 0; + if (x < 0) x = -x; + while (i < SCM_DIGSPERLONG) {digs[i++] = SCM_BIGLO(x); x = SCM_BIGDN(x);} +} +#endif + + +#ifdef __STDC__ +SCM +scm_addbig(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny) +#else +SCM +scm_addbig(x, nx, xsgn, bigy, sgny) + SCM_BIGDIG *x; + scm_sizet nx; + int xsgn; + SCM bigy; + int sgny; +#endif +{ + /* 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_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); +} + +#ifdef __STDC__ +SCM +scm_mulbig(SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn) +#else +SCM +scm_mulbig(x, nx, y, ny, sgn) + SCM_BIGDIG *x; + scm_sizet nx; + SCM_BIGDIG *y; + scm_sizet ny; + int sgn; +#endif +{ + 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); +} + +#ifdef __STDC__ +unsigned int +scm_divbigdig(SCM_BIGDIG *ds, scm_sizet h, SCM_BIGDIG div) +#else +unsigned int +scm_divbigdig(ds, h, div) + SCM_BIGDIG *ds; + scm_sizet h; + SCM_BIGDIG div; +#endif +{ + register unsigned long t2 = 0; + while(h--) { + t2 = SCM_BIGUP(t2) + ds[h]; + ds[h] = t2 / div; + t2 %= div; + } + return t2; +} + + +#ifdef __STDC__ +SCM +scm_divbigint(SCM x, long z, int sgn, int mode) +#else +SCM +scm_divbigint(x, z, sgn, mode) + SCM x; + long z; + int sgn; + int mode; +#endif +{ + 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 = 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 + } +} + +#ifdef __STDC__ +SCM +scm_divbigbig(SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes) +#else +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; +#endif +{ + /* 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}; + + + +#ifdef __STDC__ +static scm_sizet +idbl2str(double f, char *a) +#else +static scm_sizet +idbl2str(f, a) + double f; + char *a; +#endif +{ + 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; +} + +#ifdef __STDC__ +static scm_sizet +iflo2str(SCM flt, char *str) +#else +static scm_sizet +iflo2str(flt, str) + SCM flt; + char *str; +#endif +{ + 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 */ + +#ifdef __STDC__ +scm_sizet +scm_iint2str(long num, int rad, char *p) +#else +scm_sizet +scm_iint2str(num, rad, p) + long num; + int rad; + char *p; +#endif +{ + 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 +#ifdef __STDC__ +static SCM +big2str(SCM b, register unsigned int radix) +#else +static SCM +big2str(b, radix) + SCM b; + register unsigned int radix; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_number_to_string(SCM x, SCM radix) +#else +SCM +scm_number_to_string(x, radix) + SCM x; + SCM radix; +#endif +{ + 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 */ +#ifdef __STDC__ +int +scm_floprint(SCM sexp, SCM port, int writing) +#else +int +scm_floprint(sexp, port, writing) + SCM sexp; + SCM port; + int writing; +#endif +{ +#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; +} + + +#ifdef __STDC__ +int +scm_bigprint(SCM exp, SCM port, int writing) +#else +int +scm_bigprint(exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ +#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 ***/ +#ifdef SCM_BIGDIG +#ifdef __STDC__ +SCM +scm_istr2int(char *str, long len, long radix) +#else +SCM +scm_istr2int(str, len, radix) + char *str; + long len; + long radix; +#endif +{ + 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 */ + 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); + } + SCM_ASSERT(blen <= j, (SCM)SCM_MAKINUM(blen), SCM_OVSCM_FLOW, "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); +} +#else + + + +#ifdef __STDC__ +SCM +scm_istr2int(char *str, long len, long radix) +#else +SCM +scm_istr2int(str, len, radix) + char *str; + long len; + long radix; +#endif +{ + 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; +} +#endif + +#ifdef SCM_FLOATS +#ifdef __STDC__ +SCM +scm_istr2flo(char *str, long len, long radix) +#else +SCM +scm_istr2flo(str, len, radix) + char *str; + long len; + long radix; +#endif +{ + 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 */ + + +#ifdef __STDC__ +SCM +scm_istring2number(char *str, long len, long radix) +#else +SCM +scm_istring2number(str, len, radix) + char *str; + long len; + long radix; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_to_number(SCM str, SCM radix) +#else +SCM +scm_string_to_number(str, radix) + SCM str; + SCM radix; +#endif +{ + 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 +#ifdef __STDC__ +SCM +scm_makdbl (double x, double y) +#else +SCM +scm_makdbl (x, y) + double x; + double y; +#endif +{ + 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_CAR(z) = scm_tc_flo; + SCM_FLO(z) = x; + SCM_ALLOW_INTS; + return z; + } +# endif/* def SCM_SINGLES */ + SCM_CDR(z) = (SCM)scm_must_malloc(1L*sizeof(double), "real"); + SCM_CAR(z) = scm_tc_dblr; + } + else { + SCM_CDR(z) = (SCM)scm_must_malloc(2L*sizeof(double), "complex"); + SCM_CAR(z) = scm_tc_dblc; + SCM_IMAG(z) = y; + } + SCM_REAL(z) = x; + SCM_ALLOW_INTS; + return z; +} +#endif + + +#ifdef __STDC__ +SCM +scm_bigequal(SCM x, SCM y) +#else +SCM +scm_bigequal(x, y) + SCM x; + SCM y; +#endif +{ +#ifdef SCM_BIGDIG + if (0==scm_bigcomp(x, y)) return SCM_BOOL_T; +#endif + return SCM_BOOL_F; +} + + +#ifdef __STDC__ +SCM +scm_floequal(SCM x, SCM y) +#else +SCM +scm_floequal(x, y) + SCM x; + SCM y; +#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_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); +#ifdef __STDC__ +SCM +scm_number_p(SCM x) +#else +SCM +scm_number_p(x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_real_p(SCM x) +#else +SCM +scm_real_p(x) + SCM x; +#endif +{ + 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, "int?", 1, 0, 0, scm_int_p); +#ifdef __STDC__ +SCM +scm_int_p(SCM x) +#else +SCM +scm_int_p(x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_inexact_p(SCM x) +#else +SCM +scm_inexact_p(x) + SCM x; +#endif +{ +#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); +#ifdef __STDC__ +SCM +scm_num_eq_p (SCM x, SCM y) +#else +SCM +scm_num_eq_p (x, y) + SCM x; + SCM y; +#endif +{ +#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); +#ifdef __STDC__ +SCM +scm_less_p(SCM x, SCM y) +#else +SCM +scm_less_p(x, y) + SCM x; + SCM y; +#endif +{ +#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); +#ifdef __STDC__ +SCM +scm_gr_p(SCM x, SCM y) +#else +SCM +scm_gr_p(x, y) + SCM x; + SCM y; +#endif +{ + return scm_less_p(y, x); +} + + + +SCM_PROC1 (s_leq_p, "<=?", scm_tc7_rpsubr, scm_leq_p); +#ifdef __STDC__ +SCM +scm_leq_p(SCM x, SCM y) +#else +SCM +scm_leq_p(x, y) + SCM x; + SCM y; +#endif +{ + return SCM_BOOL_NOT(scm_less_p(y, x)); +} + + + +SCM_PROC1 (s_geq_p, ">=?", scm_tc7_rpsubr, scm_geq_p); +#ifdef __STDC__ +SCM +scm_geq_p(SCM x, SCM y) +#else +SCM +scm_geq_p(x, y) + SCM x; + SCM y; +#endif +{ + return SCM_BOOL_NOT(scm_less_p(x, y)); +} + + + +SCM_PROC(s_zero_p, "zero?", 1, 0, 0, scm_zero_p); +#ifdef __STDC__ +SCM +scm_zero_p(SCM z) +#else +SCM +scm_zero_p(z) + SCM z; +#endif +{ +#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); +#ifdef __STDC__ +SCM +scm_positive_p(SCM x) +#else +SCM +scm_positive_p(x) + SCM x; +#endif +{ +#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); +#ifdef __STDC__ +SCM +scm_negative_p(SCM x) +#else +SCM +scm_negative_p(x) + SCM x; +#endif +{ +#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); +#ifdef __STDC__ +SCM +scm_max(SCM x, SCM y) +#else +SCM +scm_max(x, y) + SCM x; + SCM y; +#endif +{ +#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); +#ifdef __STDC__ +SCM +scm_min(SCM x, SCM y) +#else +SCM +scm_min(x, y) + SCM x; + SCM y; +#endif +{ +#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); +#ifdef __STDC__ +SCM +scm_sum(SCM x, SCM y) +#else +SCM +scm_sum(x, y) + SCM x; + SCM y; +#endif +{ + 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_wta(y, (char *)SCM_OVSCM_FLOW, s_sum); + return SCM_UNSPECIFIED; +# endif +#endif +} + + + + +SCM_PROC1 (s_difference, "-", scm_tc7_asubr, scm_difference); +#ifdef __STDC__ +SCM +scm_difference(SCM x, SCM y) +#else +SCM +scm_difference(x, y) + SCM x; + SCM y; +#endif +{ +#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_wta(y, (char *)SCM_OVSCM_FLOW, s_difference); + return SCM_UNSPECIFIED; +# endif +#endif +} + + + + +SCM_PROC1 (s_product, "*", scm_tc7_asubr, scm_product); +#ifdef __STDC__ +SCM +scm_product(SCM x, SCM y) +#else +SCM +scm_product(x, y) + SCM x; + SCM y; +#endif +{ + 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_wta(y, (char *)SCM_OVSCM_FLOW, s_product); +# endif +#endif + return y; + } +} + + +#ifdef __STDC__ +double +scm_num2dbl (SCM a, char * why) +#else +double +scm_num2dbl (a, why) + SCM a; + char * why; +#endif +{ + 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_PROC(s_fuck, "fuck", 1, 0, 0, scm_fuck); +#ifdef __STDC__ +SCM +scm_fuck (SCM a) +#else +SCM +scm_fuck (a) + SCM a; +#endif +{ + return scm_makdbl (scm_num2dbl (a, "just because"), 0.0); +} + +SCM_PROC1 (s_divide, "/", scm_tc7_asubr, scm_divide); +#ifdef __STDC__ +SCM +scm_divide(SCM x, SCM y) +#else +SCM +scm_divide(x, y) + SCM x; + SCM y; +#endif +{ +#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); + SCM_ASSERT(z, y, SCM_OVSCM_FLOW, s_divide); + 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_wta(x, (char *)SCM_OVSCM_FLOW, s_divide); + return SCM_UNSPECIFIED; +#endif + } +} + + + + +#ifdef SCM_FLOATS +SCM_PROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh); +#ifdef __STDC__ +double +scm_asinh(double x) +#else +double +scm_asinh(x) + double x; +#endif +{ + return log(x+sqrt(x*x+1)); +} + + + + +SCM_PROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh); +#ifdef __STDC__ +double +scm_acosh(double x) +#else +double +scm_acosh(x) + double x; +#endif +{ + return log(x+sqrt(x*x-1)); +} + + + + +SCM_PROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh); +#ifdef __STDC__ +double +scm_atanh(double x) +#else +double +scm_atanh(x) + double x; +#endif +{ + return 0.5*log((1+x)/(1-x)); +} + + + + +SCM_PROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate); +#ifdef __STDC__ +double +scm_truncate(double x) +#else +double +scm_truncate(x) + double x; +#endif +{ + if (x < 0.0) return -floor(-x); + return floor(x); +} + + + +SCM_PROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round); +#ifdef __STDC__ +double +scm_round(double x) +#else +double +scm_round(x) + double x; +#endif +{ + 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); +#ifdef __STDC__ +double +scm_exact_to_inexact(double z) +#else +double +scm_exact_to_inexact(z) + double z; +#endif +{ + 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;}; + +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); +#ifdef __STDC__ +SCM +scm_sys_expt(SCM z1, SCM z2) +#else +SCM +scm_sys_expt(z1, z2) + SCM z1; + SCM z2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_sys_atan2(SCM z1, SCM z2) +#else +SCM +scm_sys_atan2(z1, z2) + SCM z1; + SCM z2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_make_rectangular(SCM z1, SCM z2) +#else +SCM +scm_make_rectangular(z1, z2) + SCM z1; + SCM z2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_make_polar(SCM z1, SCM z2) +#else +SCM +scm_make_polar(z1, z2) + SCM z1; + SCM z2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_real_part(SCM z) +#else +SCM +scm_real_part(z) + SCM z; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_imag_part(SCM z) +#else +SCM +scm_imag_part(z) + SCM z; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_magnitude(SCM z) +#else +SCM +scm_magnitude(z) + SCM z; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_angle(SCM z) +#else +SCM +scm_angle(z) + SCM z; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_inexact_to_exact(SCM z) +#else +SCM +scm_inexact_to_exact(z) + SCM z; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_trunc(SCM x) +#else +SCM +scm_trunc(x) + SCM x; +#endif +{ + 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 */ +#ifdef __STDC__ +SCM +scm_dbl2big(double d) +#else +SCM +scm_dbl2big(d) + double d; +#endif +{ + 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; + } + SCM_ASSERT(0==u, SCM_INUM0, SCM_OVSCM_FLOW, "dbl2big"); + return ans; +} + + + +#ifdef __STDC__ +double +scm_big2dbl(SCM b) +#else +double +scm_big2dbl(b) + SCM b; +#endif +{ + 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 + +#ifdef __STDC__ +SCM +scm_long2num(long sl) +#else +SCM +scm_long2num(sl) + long sl; +#endif +{ + 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 +#ifdef __STDC__ +SCM +scm_long_long2num(long_long sl) +#else +SCM +scm_long_long2num(sl) + long_long sl; +#endif +{ + 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 + + +#ifdef __STDC__ +SCM +scm_ulong2num(unsigned long sl) +#else +SCM +scm_ulong2num(sl) + unsigned long sl; +#endif +{ + if (!SCM_POSSCM_FIXABLE(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); +} + +#ifdef __STDC__ +long +scm_num2long(SCM num, char *pos, char *s_caller) +#else +long +scm_num2long(num, pos, s_caller) + SCM num; + char *pos; + char *s_caller; +#endif +{ + 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; +} + + + + +#ifdef __STDC__ +long +num2long(SCM num, char *pos, char *s_caller) +#else +long +num2long(num, pos, s_caller) + SCM num; + char *pos; + char *s_caller; +#endif +{ + 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 +#ifdef __STDC__ +long_long +scm_num2long_long(SCM num, char *pos, char *s_caller) +#else +long_long +scm_num2long_long(num, pos, s_caller) + SCM num; + char *pos; + char *s_caller; +#endif +{ + 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_LONGLONGSCM_BIGUP(res) + SCM_BDIGITS(num)[l]; + return res; + } +#endif + errout: scm_wta(num, pos, s_caller); + return SCM_UNSPECIFIED; +} +#endif + + +#ifdef __STDC__ +unsigned long +scm_num2ulong(SCM num, char *pos, char *s_caller) +#else +unsigned long +scm_num2ulong(num, pos, s_caller) + SCM num; + char *pos; + char *s_caller; +#endif +{ + 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(f, fsum) + double f, *fsum; +{ + *fsum = f + 1.0; +} +# endif +#endif + + +#ifdef __STDC__ +void +scm_init_numbers (void) +#else +void +scm_init_numbers () +#endif +{ +#ifdef SCM_FLOATS + SCM_NEWCELL(scm_flo0); +# ifdef SCM_SINGLES + SCM_CAR(scm_flo0) = scm_tc_flo; + SCM_FLO(scm_flo0) = 0.0; +# else + SCM_CDR(scm_flo0) = (SCM)scm_must_malloc(1L*sizeof(double), "real"); + SCM_REAL(scm_flo0) = 0.0; + SCM_CAR(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 new file mode 100644 index 000000000..abd1e7a24 --- /dev/null +++ b/libguile/numbers.h @@ -0,0 +1,436 @@ +/* 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 "__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_POSSCM_FIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM) +#define SCM_NEGSCM_FIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM) +#define SCM_UNEGSCM_FIXABLE(n) ((n) <= -SCM_MOST_NEGATIVE_FIXNUM) +#define SCM_FIXABLE(n) (SCM_POSSCM_FIXABLE(n) && SCM_NEGSCM_FIXABLE(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_LONGLONGSCM_BIGUP(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 NO_SCM_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_CAR(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 + + + + +#ifdef __STDC__ +extern SCM scm_exact_p(SCM x); +extern SCM scm_odd_p(SCM n); +extern SCM scm_even_p(SCM n); +extern SCM scm_abs(SCM x); +extern SCM scm_quotient(SCM x, SCM y); +extern SCM scm_remainder(SCM x, SCM y); +extern SCM scm_modulo(SCM x, SCM y); +extern SCM scm_gcd(SCM x, SCM y); +extern SCM scm_lcm(SCM n1, SCM n2); +extern SCM scm_logand(SCM n1, SCM n2); +extern SCM scm_logior(SCM n1, SCM n2); +extern SCM scm_logxor(SCM n1, SCM n2); +extern SCM scm_logtest(SCM n1, SCM n2); +extern SCM scm_logbit_p(SCM n1, SCM n2); +extern SCM scm_logand(SCM n1, SCM n2); +extern SCM scm_logior(SCM n1, SCM n2); +extern SCM scm_logxor(SCM n1, SCM n2); +extern SCM scm_logtest(SCM n1, SCM n2); +extern SCM scm_logbit_p(SCM n1, SCM n2); +extern SCM scm_lognot(SCM n); +extern SCM scm_integer_expt(SCM z1, SCM z2); +extern SCM scm_ash(SCM n, SCM cnt); +extern SCM scm_bit_extract(SCM n, SCM start, SCM end); +extern SCM scm_logcount (SCM n); +extern SCM scm_integer_length(SCM n); +extern SCM scm_mkbig(scm_sizet nlen, int sign); +extern SCM scm_big2inum(SCM b, scm_sizet l); +extern SCM scm_adjbig(SCM b, scm_sizet nlen); +extern SCM scm_normbig(SCM b); +extern SCM scm_copybig(SCM b, int sign); +extern SCM scm_long2big(long n); +extern SCM scm_long_long2big(long_long n); +extern SCM scm_2ulong2big(unsigned long * np); +extern SCM scm_ulong2big(unsigned long n); +extern int scm_bigcomp(SCM x, SCM y); +extern long scm_pseudolong(long x); +extern void scm_longdigs(long x, SCM_BIGDIG digs[]); +extern SCM scm_addbig(SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny); +extern SCM scm_mulbig(SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn); +extern unsigned int scm_divbigdig(SCM_BIGDIG *ds, scm_sizet h, SCM_BIGDIG div); +extern SCM scm_divbigint(SCM x, long z, int sgn, int mode); +extern SCM scm_divbigbig(SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes); +extern scm_sizet scm_iint2str(long num, int rad, char *p); +extern SCM scm_number_to_string(SCM x, SCM radix); +extern int scm_floprint(SCM sexp, SCM port, int writing); +extern int scm_bigprint(SCM exp, SCM port, int writing); +extern SCM scm_istr2int(char *str, long len, long radix); +extern SCM scm_istr2int(char *str, long len, long radix); +extern SCM scm_istr2flo(char *str, long len, long radix); +extern SCM scm_istring2number(char *str, long len, long radix); +extern SCM scm_string_to_number(SCM str, SCM radix); +extern SCM scm_makdbl (double x, double y); +extern SCM scm_bigequal(SCM x, SCM y); +extern SCM scm_floequal(SCM x, SCM y); +extern SCM scm_number_p(SCM x); +extern SCM scm_real_p(SCM x); +extern SCM scm_int_p(SCM x); +extern SCM scm_inexact_p(SCM x); +extern SCM scm_num_eq_p (SCM x, SCM y); +extern SCM scm_less_p(SCM x, SCM y); +extern SCM scm_gr_p(SCM x, SCM y); +extern SCM scm_leq_p(SCM x, SCM y); +extern SCM scm_geq_p(SCM x, SCM y); +extern SCM scm_zero_p(SCM z); +extern SCM scm_positive_p(SCM x); +extern SCM scm_negative_p(SCM x); +extern SCM scm_max(SCM x, SCM y); +extern SCM scm_min(SCM x, SCM y); +extern SCM scm_sum(SCM x, SCM y); +extern SCM scm_difference(SCM x, SCM y); +extern SCM scm_product(SCM x, SCM y); +extern double scm_num2dbl (SCM a, char * why); +extern SCM scm_fuck (SCM a); +extern SCM scm_divide(SCM x, SCM y); +extern double scm_asinh(double x); +extern double scm_acosh(double x); +extern double scm_atanh(double x); +extern double scm_truncate(double x); +extern double scm_round(double x); +extern double scm_exact_to_inexact(double z); +extern SCM scm_sys_expt(SCM z1, SCM z2); +extern SCM scm_sys_atan2(SCM z1, SCM z2); +extern SCM scm_make_rectangular(SCM z1, SCM z2); +extern SCM scm_make_polar(SCM z1, SCM z2); +extern SCM scm_real_part(SCM z); +extern SCM scm_imag_part(SCM z); +extern SCM scm_magnitude(SCM z); +extern SCM scm_angle(SCM z); +extern SCM scm_inexact_to_exact(SCM z); +extern SCM scm_trunc(SCM x); +extern SCM scm_dbl2big(double d); +extern double scm_big2dbl(SCM b); +extern SCM scm_long2num(long sl); +extern SCM scm_long_long2num(long_long sl); +extern SCM scm_ulong2num(unsigned long sl); +extern long scm_num2long(SCM num, char *pos, char *s_caller); +extern long num2long(SCM num, char *pos, char *s_caller); +extern long_long scm_num2long_long(SCM num, char *pos, char *s_caller); +extern unsigned long scm_num2ulong(SCM num, char *pos, char *s_caller); +extern void scm_init_numbers (void); + +#else /* STDC */ +extern SCM scm_exact_p(); +extern SCM scm_odd_p(); +extern SCM scm_even_p(); +extern SCM scm_abs(); +extern SCM scm_quotient(); +extern SCM scm_remainder(); +extern SCM scm_modulo(); +extern SCM scm_gcd(); +extern SCM scm_lcm(); +extern SCM scm_logand(); +extern SCM scm_logior(); +extern SCM scm_logxor(); +extern SCM scm_logtest(); +extern SCM scm_logbit_p(); +extern SCM scm_logand(); +extern SCM scm_logior(); +extern SCM scm_logxor(); +extern SCM scm_logtest(); +extern SCM scm_logbit_p(); +extern SCM scm_lognot(); +extern SCM scm_integer_expt(); +extern SCM scm_ash(); +extern SCM scm_bit_extract(); +extern SCM scm_logcount (); +extern SCM scm_integer_length(); +extern SCM scm_mkbig(); +extern SCM scm_big2inum(); +extern SCM scm_adjbig(); +extern SCM scm_normbig(); +extern SCM scm_copybig(); +extern SCM scm_long2big(); +extern SCM scm_long_long2big(); +extern SCM scm_2ulong2big(); +extern SCM scm_ulong2big(); +extern int scm_bigcomp(); +extern long scm_pseudolong(); +extern void scm_longdigs(); +extern SCM scm_addbig(); +extern SCM scm_mulbig(); +extern unsigned int scm_divbigdig(); +extern SCM scm_divbigint(); +extern SCM scm_divbigbig(); +extern scm_sizet scm_iint2str(); +extern SCM scm_number_to_string(); +extern int scm_floprint(); +extern int scm_bigprint(); +extern SCM scm_istr2int(); +extern SCM scm_istr2int(); +extern SCM scm_istr2flo(); +extern SCM scm_istring2number(); +extern SCM scm_string_to_number(); +extern SCM scm_makdbl (); +extern SCM scm_bigequal(); +extern SCM scm_floequal(); +extern SCM scm_number_p(); +extern SCM scm_real_p(); +extern SCM scm_int_p(); +extern SCM scm_inexact_p(); +extern SCM scm_num_eq_p (); +extern SCM scm_less_p(); +extern SCM scm_gr_p(); +extern SCM scm_leq_p(); +extern SCM scm_geq_p(); +extern SCM scm_zero_p(); +extern SCM scm_positive_p(); +extern SCM scm_negative_p(); +extern SCM scm_max(); +extern SCM scm_min(); +extern SCM scm_sum(); +extern SCM scm_difference(); +extern SCM scm_product(); +extern double scm_num2dbl (); +extern SCM scm_fuck (); +extern SCM scm_divide(); +extern double scm_asinh(); +extern double scm_acosh(); +extern double scm_atanh(); +extern double scm_truncate(); +extern double scm_round(); +extern double scm_exact_to_inexact(); +extern SCM scm_sys_expt(); +extern SCM scm_sys_atan2(); +extern SCM scm_make_rectangular(); +extern SCM scm_make_polar(); +extern SCM scm_real_part(); +extern SCM scm_imag_part(); +extern SCM scm_magnitude(); +extern SCM scm_angle(); +extern SCM scm_inexact_to_exact(); +extern SCM scm_trunc(); +extern SCM scm_dbl2big(); +extern double scm_big2dbl(); +extern SCM scm_long2num(); +extern SCM scm_long_long2num(); +extern SCM scm_ulong2num(); +extern long scm_num2long(); +extern long num2long(); +extern long_long scm_num2long_long(); +extern unsigned long scm_num2ulong(); +extern void scm_init_numbers (); + +#endif /* STDC */ + + + +#endif /* NUMBERSH */ diff --git a/libguile/objprop.c b/libguile/objprop.c new file mode 100644 index 000000000..e97b591ce --- /dev/null +++ b/libguile/objprop.c @@ -0,0 +1,137 @@ +/* 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" + + + +/* {Object Properties} + */ + +SCM_PROC(s_object_properties, "object-properties", 1, 0, 0, scm_object_properties); +#ifdef __STDC__ +SCM +scm_object_properties (SCM obj) +#else +SCM +scm_object_properties (obj) + SCM obj; +#endif +{ + return scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL); +} + + +SCM_PROC(s_set_object_properties_x, "set-object-properties!", 2, 0, 0, scm_set_object_properties_x); +#ifdef __STDC__ +SCM +scm_set_object_properties_x (SCM obj, SCM plist) +#else +SCM +scm_set_object_properties_x (obj, plist) + SCM obj; + SCM plist; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_object_property (SCM obj, SCM key) +#else +SCM +scm_object_property (obj, key) + SCM obj; + SCM key; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_set_object_property_x (SCM obj, SCM key, SCM val) +#else +SCM +scm_set_object_property_x (obj, key, val) + SCM obj; + SCM key; + SCM val; +#endif +{ + 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; +} + +#ifdef __STDC__ +void +scm_init_objprop (void) +#else +void +scm_init_objprop () +#endif +{ + scm_object_whash = scm_make_weak_hash_table (SCM_MAKINUM (511)); +#include "objprop.x" +} + diff --git a/libguile/objprop.h b/libguile/objprop.h new file mode 100644 index 000000000..af3771c22 --- /dev/null +++ b/libguile/objprop.h @@ -0,0 +1,73 @@ +/* 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 "_scm.h" + + + + + + +#ifdef __STDC__ +extern SCM scm_object_properties (SCM obj); +extern SCM scm_set_object_properties_x (SCM obj, SCM plist); +extern SCM scm_object_property (SCM obj, SCM key); +extern SCM scm_set_object_property_x (SCM obj, SCM key, SCM val); +extern void scm_init_objprop (void); + +#else /* STDC */ +extern SCM scm_object_properties (); +extern SCM scm_set_object_properties_x (); +extern SCM scm_object_property (); +extern SCM scm_set_object_property_x (); +extern void scm_init_objprop (); + +#endif /* STDC */ + + + +#endif /* OBJPROPH */ diff --git a/libguile/pairs.c b/libguile/pairs.c new file mode 100644 index 000000000..26cd3da1f --- /dev/null +++ b/libguile/pairs.c @@ -0,0 +1,196 @@ +/* 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" + +#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 + + + + +/* {Pairs} + */ + +SCM_PROC(s_cons, "cons", 2, 0, 0, scm_cons); +#ifdef __STDC__ +SCM +scm_cons (SCM x, SCM y) +#else +SCM +scm_cons (x, y) + SCM x; + SCM y; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CAR (z) = x; + SCM_CDR (z) = y; + return z; +} + +#ifdef __STDC__ +SCM +scm_cons2 (SCM w, SCM x, SCM y) +#else +SCM +scm_cons2 (w, x, y) + SCM w; + SCM x; + SCM y; +#endif +{ + register SCM z; + SCM_NEWCELL (z); + SCM_CAR (z) = x; + SCM_CDR (z) = y; + x = z; + SCM_NEWCELL (z); + SCM_CAR (z) = w; + SCM_CDR (z) = x; + return z; +} + + +SCM_PROC(s_pair_p, "pair?", 1, 0, 0, scm_pair_p); +#ifdef __STDC__ +SCM +scm_pair_p(SCM x) +#else +SCM +scm_pair_p(x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_set_car_x(SCM pair, SCM value) +#else +SCM +scm_set_car_x(pair, value) + SCM pair; + SCM value; +#endif +{ + SCM_ASSERT(SCM_NIMP(pair) && SCM_CONSP(pair), pair, SCM_ARG1, s_set_car_x); + SCM_CAR(pair) = value; + return value; +} + +SCM_PROC(s_set_cdr_x, "set-cdr!", 2, 0, 0, scm_set_cdr_x); +#ifdef __STDC__ +SCM +scm_set_cdr_x(SCM pair, SCM value) +#else +SCM +scm_set_cdr_x(pair, value) + SCM pair; + SCM value; +#endif +{ + SCM_ASSERT(SCM_NIMP(pair) && SCM_CONSP(pair), pair, SCM_ARG1, s_set_cdr_x); + SCM_CDR(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} +}; + + +#ifdef __STDC__ +void +scm_init_pairs (void) +#else +void +scm_init_pairs () +#endif +{ + scm_init_iprocs(cxrs, scm_tc7_cxr); +#include "pairs.x" +} + diff --git a/libguile/pairs.h b/libguile/pairs.h new file mode 100644 index 000000000..b27e9c908 --- /dev/null +++ b/libguile/pairs.h @@ -0,0 +1,170 @@ +/* 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 "__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_EOL SCM_BOOL_F +#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_SETCDR(x, v) SCM_CDR(x) = (SCM)(v) +#define SCM_SETCAR(x, v) SCM_CAR(x) = (SCM)(v) + +#define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ)) +#define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ)) +#define SCM_CADR(OBJ) SCM_CAR (SCM_CDR (OBJ)) +#define SCM_CDDR(OBJ) SCM_CDR (SCM_CDR (OBJ)) + +#define SCM_CAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (OBJ))) +#define SCM_CDAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (OBJ))) +#define SCM_CADAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (OBJ))) +#define SCM_CDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (OBJ))) +#define SCM_CAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (OBJ))) +#define SCM_CDADR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (OBJ))) +#define SCM_CADDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (OBJ))) +#define SCM_CDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (OBJ))) + +#define SCM_CAAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ)))) +#define SCM_CDAAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ)))) +#define SCM_CADAAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ)))) +#define SCM_CDDAAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ)))) +#define SCM_CAADAR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ)))) +#define SCM_CDADAR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ)))) +#define SCM_CADDAR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ)))) +#define SCM_CDDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ)))) +#define SCM_CAAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ)))) +#define SCM_CDAADR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ)))) +#define SCM_CADADR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ)))) +#define SCM_CDDADR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ)))) +#define SCM_CAADDR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ)))) +#define SCM_CDADDR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ)))) +#define SCM_CADDDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ)))) +#define SCM_CDDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ)))) + + +#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; \ + } \ + } + + +#ifdef __STDC__ +extern SCM scm_cons (SCM x, SCM y); +extern SCM scm_cons2 (SCM w, SCM x, SCM y); +extern SCM scm_pair_p(SCM x); +extern SCM scm_set_car_x(SCM pair, SCM value); +extern SCM scm_set_cdr_x(SCM pair, SCM value); +extern void scm_init_pairs (void); + +#else /* STDC */ +extern SCM scm_cons (); +extern SCM scm_cons2 (); +extern SCM scm_pair_p(); +extern SCM scm_set_car_x(); +extern SCM scm_set_cdr_x(); +extern void scm_init_pairs (); + +#endif /* STDC */ +#endif /* PAIRSH */ diff --git a/libguile/ports.c b/libguile/ports.c new file mode 100644 index 000000000..cbaecbc03 --- /dev/null +++ b/libguile/ports.c @@ -0,0 +1,1000 @@ +/* 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" + + +#ifdef HAVE_MALLOC_H +#include "malloc.h" +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.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; + +#ifdef __STDC__ +SCM +scm_markstream (SCM ptr) +#else +SCM +scm_markstream (ptr) + SCM ptr; +#endif +{ + 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; +} + + +#ifdef __STDC__ +long +scm_newptob (scm_ptobfuns *ptob) +#else +long +scm_newptob (ptob) + scm_ptobfuns *ptob; +#endif +{ + 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 */ +#ifdef __STDC__ +void +scm_fflush (SCM port) +#else +void +scm_fflush (port) + SCM port; +#endif +{ + scm_sizet i = SCM_PTOBNUM (port); + (scm_ptobs[i].fflush) (SCM_STREAM (port)); +} + + + + +#ifdef __IBMC__ +# define MSDOS +#endif +#ifdef MSDOS +# ifndef GO32 +# include <io.h> +# include <conio.h> +#ifdef __STDC__ +static int +input_waiting (FILE *f) +#else +static int +input_waiting (f) + FILE *f; +#endif +{ + 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 + + +#ifdef __STDC__ +static int +input_waiting(FILE *f) +#else +static int +input_waiting(f) + FILE *f; +#endif +{ +# ifdef FIONREAD + long remir; + if (feof(f)) return 1; + ioctl(fileno(f), FIONREAD, &remir); + return remir; +# else + return -1; +# endif +} +#endif + +SCM_PROC(s_char_ready_p, "char-ready?", 1, 0, 0, scm_char_ready_p); +#ifdef __STDC__ +SCM +scm_char_ready_p (SCM port) +#else +SCM +scm_char_ready_p (port) + SCM port; +#endif +{ + 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 input_waiting ((FILE *)SCM_STREAM (port)) ? SCM_BOOL_T : SCM_BOOL_F; +} + + + + +SCM_PROC (s_ungetc_char_ready_p, "ungetc-char-ready?", 1, 0, 0, scm_ungetc_char_ready_p); +#ifdef __STDC__ +SCM +scm_ungetc_char_ready_p (SCM port) +#else +SCM +scm_ungetc_char_ready_p (port) + SCM port; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_current_input_port (void) +#else +SCM +scm_current_input_port () +#endif +{ + return scm_cur_inp; +} + +SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port); +#ifdef __STDC__ +SCM +scm_current_output_port (void) +#else +SCM +scm_current_output_port () +#endif +{ + return scm_cur_outp; +} + +SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port); +#ifdef __STDC__ +SCM +scm_current_error_port (void) +#else +SCM +scm_current_error_port () +#endif +{ + return scm_cur_errp; +} + +SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port); +#ifdef __STDC__ +SCM +scm_set_current_input_port (SCM port) +#else +SCM +scm_set_current_input_port (port) + SCM port; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_set_current_output_port (SCM port) +#else +SCM +scm_set_current_output_port (port) + SCM port; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_set_current_error_port (SCM port) +#else +SCM +scm_set_current_error_port (port) + SCM port; +#endif +{ + 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. */ +#ifdef __STDC__ +struct scm_port_table * +scm_add_to_port_table (SCM port) +#else +struct scm_port_table * +scm_add_to_port_table (port) + SCM port; +#endif +{ + 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. */ +#ifdef __STDC__ +void +scm_remove_from_port_table (SCM port) +#else +void +scm_remove_from_port_table (port) + SCM port; +#endif +{ + 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"; +#ifdef __STDC__ +SCM +scm_pt_size (void) +#else +SCM +scm_pt_size () +#endif +{ + return SCM_MAKINUM (scm_port_table_size); +} + +/* Return the ith member of the port table. */ +static char s_pt_member[] = "pt-member"; +#ifdef __STDC__ +SCM +scm_pt_member (SCM member) +#else +SCM +scm_pt_member (member) + SCM member; +#endif +{ + 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. Return -1 + * if the port isn't in the table (should not happen). Also used by + * the garbage collector. + */ +#ifdef __STDC__ +int +scm_revealed_count (SCM port) +#else +int +scm_revealed_count (port) + SCM port; +#endif +{ + return SCM_REVEALED(port); +} + + + +/* Return the revealed count for a port. */ + +SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed); +#ifdef __STDC__ +SCM +scm_port_revealed (SCM port) +#else +SCM +scm_port_revealed (port) + SCM port; +#endif +{ + int result; + + SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed); + + if ((result = scm_revealed_count (port)) == -1) + return SCM_BOOL_F; + else + return SCM_MAKINUM (result); +} + +/* 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); +#ifdef __STDC__ +SCM +scm_set_port_revealed_x (SCM port, SCM rcount) +#else +SCM +scm_set_port_revealed_x (port, rcount) + SCM port; + SCM rcount; +#endif +{ + 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_BOOL_F; +} + +/* scm_close_port + * Call the close operation on a port object. + */ +SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port); +#ifdef __STDC__ +SCM +scm_close_port (SCM port) +#else +SCM +scm_close_port (port) + SCM port; +#endif +{ + 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_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); +#ifdef __STDC__ +SCM +scm_close_all_ports_except (SCM ports) +#else +SCM +scm_close_all_ports_except (ports) + SCM ports; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_input_port_p (SCM x) +#else +SCM +scm_input_port_p (x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_output_port_p (SCM x) +#else +SCM +scm_output_port_p (x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_eof_object_p (SCM x) +#else +SCM +scm_eof_object_p (x) + SCM x; +#endif +{ + return (SCM_EOF_VAL == x) ? SCM_BOOL_T : SCM_BOOL_F; +} + +SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output); +#ifdef __STDC__ +SCM +scm_force_output (SCM port) +#else +SCM +scm_force_output (port) + SCM port; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_read_char (SCM port) +#else +SCM +scm_read_char (port) + SCM port; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_peek_char (SCM port) +#else +SCM +scm_peek_char (port) + SCM port; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_unread_char (SCM cobj, SCM port) +#else +SCM +scm_unread_char (cobj, port) + SCM cobj; + SCM port; +#endif +{ + 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_line_number, "line-number", 0, 1, 0, scm_line_number); +#ifdef __STDC__ +SCM +scm_line_number (SCM port) +#else +SCM +scm_line_number (port) + SCM port; +#endif +{ + 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_column_number, "column-number", 0, 1, 0, scm_column_number); +#ifdef __STDC__ +SCM +scm_column_number (SCM port) +#else +SCM +scm_column_number (port) + SCM port; +#endif +{ + 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)); +} + +/* !!! dubious feature */ +SCM_PROC (s_port_file_name, "port-file-name", 0, 1, 0, scm_port_file_name); +#ifdef __STDC__ +SCM +scm_port_file_name (SCM port) +#else +SCM +scm_port_file_name (port) + SCM port; +#endif +{ + 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; +} + +#ifndef ttyname +extern char * ttyname(); +#endif + +#ifdef __STDC__ +void +scm_prinport (SCM exp, SCM port, char *type) +#else +void +scm_prinport (exp, port, type) + SCM exp; + SCM port; + char *type; +#endif +{ + 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); +} + +#ifdef __STDC__ +void +scm_ports_prehistory (void) +#else +void +scm_ports_prehistory () +#endif +{ + 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; +} + +#ifdef __STDC__ +static int +flush_void_port (SCM strm) +#else +static int +flush_void_port (strm) + SCM strm; +#endif +{ + return 0; +} + +#ifdef __STDC__ +static int +getc_void_port (SCM strm) +#else +static int +getc_void_port (strm) + SCM strm; +#endif +{ + return EOF; +} + +#ifdef __STDC__ +static int +close_void_port (SCM strm) +#else +static int +close_void_port (strm) + SCM strm; +#endif +{ + return 0; /* this is ignored by scm_close_port. */ +} + + +#ifdef __STDC__ +static int +noop0 (FILE *stream) +#else +static int +noop0 (stream) + FILE *stream; +#endif +{ + 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, +}; + + + +#ifdef __STDC__ +SCM +scm_void_port (char * mode_str) +#else +SCM +scm_void_port (mode_str) + char * mode_str; +#endif +{ + 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_CAR (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); +#ifdef __STDC__ +SCM +scm_sys_make_void_port (SCM mode) +#else +SCM +scm_sys_make_void_port (mode) + SCM mode; +#endif +{ + SCM_ASSERT (SCM_NIMP (mode) && SCM_STRINGP (mode), mode, + SCM_ARG1, s_sys_make_void_port); + + return scm_void_port (SCM_ROCHARS (mode)); +} + + + + + +#ifdef __STDC__ +void +scm_init_ports (void) +#else +void +scm_init_ports () +#endif +{ + scm_tc16_void_port = scm_newptob (&void_port_ptob); +#include "ports.x" +} + diff --git a/libguile/ports.h b/libguile/ports.h new file mode 100644 index 000000000..fac20af77 --- /dev/null +++ b/libguile/ports.h @@ -0,0 +1,229 @@ +/* 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 "__scm.h" +#include "smob.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; + int unchr; /* pushed back character, if any */ + + int line_number; + int column_number; + + enum scm_port_representation_type representation; +}; + +extern struct scm_port_table **scm_port_table; +extern scm_port_table_size; /* Number of ports in scm_port_table. */ + + + + +/* PORT FLAGS + * A set of flags caracterizes 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_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_CAR(port) &= SCM_CUC;} +#define SCM_SETRDY(port) {SCM_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) += (SCM_COL (port) + 1) % 8;} + + + + + +extern scm_ptobfuns *scm_ptobs; +extern scm_sizet scm_numptob; +extern int scm_port_table_room; + + +#ifdef __STDC__ +extern SCM scm_markstream (SCM ptr); +extern long scm_newptob (scm_ptobfuns *ptob); +extern void scm_fflush (SCM port); +extern SCM scm_char_ready_p (SCM port); +extern SCM scm_ungetc_char_ready_p (SCM port); +extern SCM scm_current_input_port (void); +extern SCM scm_current_output_port (void); +extern SCM scm_current_error_port (void); +extern SCM scm_set_current_input_port (SCM port); +extern SCM scm_set_current_output_port (SCM port); +extern SCM scm_set_current_error_port (SCM port); +extern struct scm_port_table * scm_add_to_port_table (SCM port); +extern void scm_remove_from_port_table (SCM port); +extern SCM scm_pt_size (void); +extern SCM scm_pt_member (SCM member); +extern int scm_revealed_count (SCM port); +extern SCM scm_port_revealed (SCM port); +extern SCM scm_set_port_revealed_x (SCM port, SCM rcount); +extern SCM scm_close_port (SCM port); +extern SCM scm_input_port_p (SCM x); +extern SCM scm_output_port_p (SCM x); +extern SCM scm_eof_object_p (SCM x); +extern SCM scm_force_output (SCM port); +extern SCM scm_read_char (SCM port); +extern SCM scm_peek_char (SCM port); +extern SCM scm_unread_char (SCM cobj, SCM port); +extern SCM scm_line_number (SCM port); +extern SCM scm_column_number (SCM port); +extern SCM scm_port_file_name (SCM port); +extern void scm_prinport (SCM exp, SCM port, char *type); +extern void scm_ports_prehistory (void); +extern SCM scm_void_port (char * mode_str); +extern SCM scm_sys_make_void_port (SCM mode); +extern void scm_init_ports (void); + +#else /* STDC */ +extern SCM scm_markstream (); +extern long scm_newptob (); +extern void scm_fflush (); +extern SCM scm_char_ready_p (); +extern SCM scm_ungetc_char_ready_p (); +extern SCM scm_current_input_port (); +extern SCM scm_current_output_port (); +extern SCM scm_current_error_port (); +extern SCM scm_set_current_input_port (); +extern SCM scm_set_current_output_port (); +extern SCM scm_set_current_error_port (); +extern struct scm_port_table * scm_add_to_port_table (); +extern void scm_remove_from_port_table (); +extern SCM scm_pt_size (); +extern SCM scm_pt_member (); +extern int scm_revealed_count (); +extern SCM scm_port_revealed (); +extern SCM scm_set_port_revealed_x (); +extern SCM scm_close_port (); +extern SCM scm_input_port_p (); +extern SCM scm_output_port_p (); +extern SCM scm_eof_object_p (); +extern SCM scm_force_output (); +extern SCM scm_read_char (); +extern SCM scm_peek_char (); +extern SCM scm_unread_char (); +extern SCM scm_line_number (); +extern SCM scm_column_number (); +extern SCM scm_port_file_name (); +extern void scm_prinport (); +extern void scm_ports_prehistory (); +extern SCM scm_void_port (); +extern SCM scm_sys_make_void_port (); +extern void scm_init_ports (); + +#endif /* STDC */ + + + + + + + + + + + + +#endif /* PORTSH */ diff --git a/libguile/posix.c b/libguile/posix.c new file mode 100644 index 000000000..11136be1d --- /dev/null +++ b/libguile/posix.c @@ -0,0 +1,1510 @@ +/* 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" + + + +#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 HAVE_SYS_SELECT_H +#include <sys/select.h> +#endif + +#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 char *ttyname (); +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 + + + + + +SCM_PROC (s_sys_pipe, "%pipe", 0, 0, 0, scm_sys_pipe); +#ifdef __STDC__ +SCM +scm_sys_pipe (void) +#else +SCM +scm_sys_pipe () +#endif +{ + int fd[2], rv; + FILE *f_rd, *f_wt; + SCM p_rd, p_wt; + SCM_NEWCELL (p_rd); + SCM_NEWCELL (p_wt); + rv = pipe (fd); + if (rv) + { + SCM_ALLOW_INTS; + return SCM_BOOL_F; + } + f_rd = fdopen (fd[0], "r"); + if (!f_rd) + { + SCM_SYSCALL (close (fd[0])); + SCM_SYSCALL (close (fd[1])); + SCM_ALLOW_INTS; + return SCM_BOOL_F; + } + f_wt = fdopen (fd[1], "w"); + if (!f_wt) + { + int en; + en = errno; + fclose (f_rd); + SCM_SYSCALL (close (fd[1])); + SCM_ALLOW_INTS; + return SCM_MAKINUM (en); + } + { + struct scm_port_table * ptr; + struct scm_port_table * ptw; + + 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_CAR (p_rd) = scm_tc16_fport | scm_mode_bits ("r"); + SCM_CAR (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_sys_getgroups, "%getgroups", 0, 0, 0, scm_sys_getgroups); +#ifdef __STDC__ +SCM +scm_sys_getgroups(void) +#else +SCM +scm_sys_getgroups() +#endif +{ + SCM grps, ans; + int ngroups = getgroups (0, NULL); + if (!ngroups) return SCM_BOOL_F; + SCM_NEWCELL(grps); + SCM_DEFER_INTS; + { + GETGROUPS_T *groups; + int val; + + groups = (gid_t *)scm_must_malloc(ngroups * sizeof(GETGROUPS_T), + s_sys_getgroups); + val = getgroups(ngroups, groups); + if (val < 0) + { + scm_must_free((char *)groups); + SCM_ALLOW_INTS; + return SCM_MAKINUM (errno); + } + 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_sys_getpwuid, "%getpw", 0, 1, 0, scm_sys_getpwuid); +#ifdef __STDC__ +SCM +scm_sys_getpwuid (SCM user) +#else +SCM +scm_sys_getpwuid (user) + SCM user; +#endif +{ + 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_sys_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_ALLOW_INTS; + return SCM_BOOL_F; + } + 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); +#ifdef __STDC__ +SCM +scm_setpwent (SCM arg) +#else +SCM +scm_setpwent (arg) + SCM arg; +#endif +{ + if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) + endpwent (); + else + setpwent (); + return SCM_UNSPECIFIED; +} + + + +/* Combines getgrgid and getgrnam. */ +SCM_PROC (s_sys_getgrgid, "%getgr", 0, 1, 0, scm_sys_getgrgid); +#ifdef __STDC__ +SCM +scm_sys_getgrgid (SCM name) +#else +SCM +scm_sys_getgrgid (name) + SCM name; +#endif +{ + 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_sys_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_ALLOW_INTS; + return SCM_MAKINUM (errno); + } + 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); +#ifdef __STDC__ +SCM +scm_setgrent (SCM arg) +#else +SCM +scm_setgrent (arg) + SCM arg; +#endif +{ + if (SCM_UNBNDP (arg) || SCM_FALSEP (arg)) + endgrent (); + else + setgrent (); + return SCM_UNSPECIFIED; +} + + + +SCM_PROC (s_sys_kill, "%kill", 2, 0, 0, scm_sys_kill); +#ifdef __STDC__ +SCM +scm_sys_kill (SCM pid, SCM sig) +#else +SCM +scm_sys_kill (pid, sig) + SCM pid; + SCM sig; +#endif +{ + int i; + SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_sys_kill); + SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_sys_kill); + /* Signal values are interned in scm_init_posix(). */ + SCM_SYSCALL (i = kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig))); + return i ? SCM_MAKINUM (errno) : SCM_BOOL_T; +} + + + +SCM_PROC (s_sys_waitpid, "%waitpid", 1, 1, 0, scm_sys_waitpid); +#ifdef __STDC__ +SCM +scm_sys_waitpid (SCM pid, SCM options) +#else +SCM +scm_sys_waitpid (pid, options) + SCM pid; + SCM options; +#endif +{ + int i; + int status; + int ioptions; + SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_sys_waitpid); + if (SCM_UNBNDP (options)) + ioptions = 0; + else + { + SCM_ASSERT (SCM_INUMP (options), options, SCM_ARG2, s_sys_waitpid); + /* Flags are interned in scm_init_posix. */ + ioptions = SCM_INUM (options); + } + SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions)); + return ((i == -1) + ? SCM_MAKINUM (errno) + : scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status))); +} + + + +SCM_PROC (s_getppid, "getppid", 0, 0, 0, scm_getppid); +#ifdef __STDC__ +SCM +scm_getppid (void) +#else +SCM +scm_getppid () +#endif +{ + return SCM_MAKINUM (0L + getppid ()); +} + + + +SCM_PROC (s_getuid, "getuid", 0, 0, 0, scm_getuid); +#ifdef __STDC__ +SCM +scm_getuid (void) +#else +SCM +scm_getuid () +#endif +{ + return SCM_MAKINUM (0L + getuid ()); +} + + + +SCM_PROC (s_getgid, "getgid", 0, 0, 0, scm_getgid); +#ifdef __STDC__ +SCM +scm_getgid (void) +#else +SCM +scm_getgid () +#endif +{ + return SCM_MAKINUM (0L + getgid ()); +} + + + +SCM_PROC (s_geteuid, "geteuid", 0, 0, 0, scm_geteuid); +#ifdef __STDC__ +SCM +scm_geteuid (void) +#else +SCM +scm_geteuid () +#endif +{ +#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); +#ifdef __STDC__ +SCM +scm_getegid (void) +#else +SCM +scm_getegid () +#endif +{ +#ifdef HAVE_GETEUID + return SCM_MAKINUM (0L + getegid ()); +#else + return SCM_MAKINUM (0L + getgid ()); +#endif +} + + +SCM_PROC (s_sys_setuid, "%setuid", 1, 0, 0, scm_sys_setuid); +#ifdef __STDC__ +SCM +scm_sys_setuid (SCM id) +#else +SCM +scm_sys_setuid (id) + SCM id; +#endif +{ + SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setuid); + return setuid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; +} + +SCM_PROC (s_sys_setgid, "%setgid", 1, 0, 0, scm_sys_setgid); +#ifdef __STDC__ +SCM +scm_sys_setgid (SCM id) +#else +SCM +scm_sys_setgid (id) + SCM id; +#endif +{ + SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setgid); + return setgid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; +} + +SCM_PROC (s_sys_seteuid, "%seteuid", 1, 0, 0, scm_sys_seteuid); +#ifdef __STDC__ +SCM +scm_sys_seteuid (SCM id) +#else +SCM +scm_sys_seteuid (id) + SCM id; +#endif +{ + SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_seteuid); +#ifdef HAVE_SETEUID + return seteuid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; +#else + return setuid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; +#endif +} + +SCM_PROC (s_sys_setegid, "%setegid", 1, 0, 0, scm_sys_setegid); +#ifdef __STDC__ +SCM +scm_sys_setegid (SCM id) +#else +SCM +scm_sys_setegid (id) + SCM id; +#endif +{ + SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setegid); +#ifdef HAVE_SETEUID + return setegid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; +#else + return setgid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; +#endif +} + +SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp); +SCM +scm_getpgrp () +{ + int (*fn)(); + fn = getpgrp; + return SCM_MAKINUM (fn (0)); +} + +SCM_PROC (s_setpgid, "%setpgid", 2, 0, 0, scm_setpgid); +SCM +scm_setpgid (pid, pgid) + SCM pid, pgid; +{ + SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_setpgid); + SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_setpgid); + /* This may be known as setpgrp, from BSD. */ + return setpgid (SCM_INUM (pid), SCM_INUM (pgid)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; +} + +SCM_PROC (s_setsid, "%setsid", 0, 0, 0, scm_setsid); +SCM +scm_setsid () +{ + pid_t sid = setsid (); + return (sid == -1) ? SCM_BOOL_F : SCM_MAKINUM (sid); +} + +#ifndef ttyname +extern char * ttyname(); +#endif + +SCM_PROC (s_ttyname, "%ttyname", 1, 0, 0, scm_ttyname); +#ifdef __STDC__ +SCM +scm_ttyname (SCM port) +#else +SCM +scm_ttyname (port) + SCM port; +#endif +{ + 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_SYSCALL (ans = ttyname (fd)); + /* ans could be overwritten by another call to ttyname */ + return (((fd != -1) && ans) + ? scm_makfrom0str (ans) + : SCM_MAKINUM (errno)); +} + + +SCM_PROC (s_ctermid, "%ctermid", 0, 0, 0, scm_ctermid); +SCM +scm_ctermid () +{ + char *result = ctermid (NULL); + return *result == '\0' ? SCM_BOOL_F : scm_makfrom0str (result); +} + +SCM_PROC (s_tcgetpgrp, "%tcgetpgrp", 1, 0, 0, scm_tcgetpgrp); +SCM +scm_tcgetpgrp (port) + SCM port; +{ + 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) + return SCM_BOOL_F; + else + return SCM_MAKINUM (pgid); +} + +SCM_PROC (s_tcsetpgrp, "%tcsetpgrp", 2, 0, 0, scm_tcsetpgrp); +SCM +scm_tcsetpgrp (port, pgid) + SCM port, pgid; +{ + 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) + return SCM_BOOL_F; + else + return SCM_BOOL_T; +} + +/* Copy exec args from an SCM vector into a new C array. */ +#ifdef __STDC__ +static char ** +scm_convert_exec_args (SCM args) +#else +static char ** +scm_convert_exec_args (args) + SCM args; +#endif +{ + 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_sys_execl, "%execl", 0, 0, 1, scm_sys_execl); +#ifdef __STDC__ +SCM +scm_sys_execl (SCM args) +#else +SCM +scm_sys_execl (args) + SCM args; +#endif +{ + char **execargv; + SCM filename = SCM_CAR (args); + SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_sys_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); + return SCM_MAKINUM (errno); +} + +SCM_PROC (s_sys_execlp, "%execlp", 0, 0, 1, scm_sys_execlp); +#ifdef __STDC__ +SCM +scm_sys_execlp (SCM args) +#else +SCM +scm_sys_execlp (args) + SCM args; +#endif +{ + char **execargv; + SCM filename = SCM_CAR (args); + SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_sys_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); + return SCM_MAKINUM (errno); +} + +/* Flushing streams etc., is not done here. */ +SCM_PROC (s_sys_fork, "%fork", 0, 0, 0, scm_sys_fork); +#ifdef __STDC__ +SCM +scm_sys_fork(void) +#else +SCM +scm_sys_fork() +#endif +{ + pid_t pid; + pid = fork (); + if (pid == -1) + return SCM_BOOL_F; + else + return SCM_MAKINUM (0L+pid); +} + + +SCM_PROC (s_sys_uname, "%uname", 0, 0, 0, scm_sys_uname); +#ifdef __STDC__ +SCM +scm_sys_uname (void) +#else +SCM +scm_sys_uname () +#endif +{ +#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); +/* + FIXME + ve[5] = scm_makfrom0str (buf.domainname); +*/ + return ans; +#else + return SCM_MAKINUM (ENOSYS); +#endif +} + +SCM_PROC (s_environ, "environ", 0, 1, 0, scm_environ); +#ifdef __STDC__ +SCM +scm_environ (SCM env) +#else +SCM +scm_environ (env) + SCM env; +#endif +{ + 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; + } +} + + +SCM_PROC (s_open_pipe, "open-pipe", 2, 0, 0, scm_open_pipe); +#ifdef __STDC__ +SCM +scm_open_pipe (SCM pipestr, SCM modes) +#else +SCM +scm_open_pipe (pipestr, modes) + SCM pipestr; + SCM modes; +#endif +{ + FILE *f; + register SCM z; + 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) + z = SCM_BOOL_F; + else + { + struct scm_port_table * pt; + pt = scm_add_to_port_table (z); + SCM_SETPTAB_ENTRY (z, pt); + SCM_CAR (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); +#ifdef __STDC__ +SCM +scm_open_input_pipe(SCM pipestr) +#else +SCM +scm_open_input_pipe(pipestr) + SCM pipestr; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_open_output_pipe(SCM pipestr) +#else +SCM +scm_open_output_pipe(pipestr) + SCM pipestr; +#endif +{ + return scm_open_pipe(pipestr, scm_makfromstr("w", (sizeof "w")-1, 0)); +} + + +#ifdef __EMX__ +#include <sys/utime.h> +#else +#include <utime.h> +#endif + +SCM_PROC (s_sys_utime, "%utime", 1, 2, 0, scm_sys_utime); +#ifdef __STDC__ +SCM +scm_sys_utime (SCM pathname, SCM actime, SCM modtime) +#else +SCM +scm_sys_utime (pathname, actime, modtime) + SCM pathname; + SCM actime; + SCM modtime; +#endif +{ + int rv; + struct utimbuf utm_tmp; + + SCM_ASSERT (SCM_NIMP (pathname) && SCM_STRINGP (pathname), pathname, SCM_ARG1, s_sys_utime); + + if (SCM_UNBNDP (actime)) + SCM_SYSCALL (time (&utm_tmp.actime)); + else + utm_tmp.actime = scm_num2ulong (actime, (char *) SCM_ARG2, s_sys_utime); + + if (SCM_UNBNDP (modtime)) + SCM_SYSCALL (time (&utm_tmp.modtime)); + else + utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_sys_utime); + + SCM_SYSCALL (rv = utime (SCM_CHARS (pathname), &utm_tmp)); + return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T; +} + + + + + +SCM_PROC (s_sys_access, "access?", 2, 0, 0, scm_sys_access); +#ifdef __STDC__ +SCM +scm_sys_access (SCM path, SCM how) +#else +SCM +scm_sys_access (path, how) + SCM path; + SCM how; +#endif +{ + int rv; + + SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_access); + if (SCM_SUBSTRP (path)) + path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0); + SCM_ASSERT (SCM_INUMP (how), how, SCM_ARG2, s_sys_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); +#ifdef __STDC__ +SCM +scm_getpid (void) +#else +SCM +scm_getpid () +#endif +{ + return SCM_MAKINUM ((unsigned long) getpid ()); +} + + +SCM_PROC (s_sys_putenv, "%putenv", 1, 0, 0, scm_sys_putenv); +#ifdef __STDC__ +SCM +scm_sys_putenv (SCM str) +#else +SCM +scm_sys_putenv (str) + SCM str; +#endif +{ +#ifdef HAVE_PUTENV + SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_putenv); + return putenv (SCM_CHARS (str)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; +#else + return SCM_MAKINUM (ENOSYS); +#endif +} + + +SCM_PROC (s_read_line, "read-line", 0, 2, 0, scm_read_line); +#ifdef __STDC__ +SCM +scm_read_line (SCM port, SCM include_terminator) +#else +SCM +scm_read_line (port, include_terminator) + SCM port; + SCM include_terminator; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_read_line_x (SCM str, SCM port) +#else +SCM +scm_read_line_x (str, port) + SCM str; + SCM port; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_write_line (SCM obj, SCM port) +#else +SCM +scm_write_line (obj, port) + SCM obj; + SCM port; +#endif +{ + scm_display (obj, port); + return scm_newline (port); +} + + + +SCM_PROC (s_setlocale, "%setlocale", 1, 1, 0, scm_setlocale); +#ifdef __STDC__ +SCM +scm_setlocale (SCM category, SCM locale) +#else +SCM +scm_setlocale (category, locale) + SCM category; + SCM locale; +#endif +{ +#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); + return rv ? scm_makfrom0str (rv) : SCM_MAKINUM (errno); +#else + /* setlocale not available. */ + return SCM_MAKINUM (errno); +#endif +} + +SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime); +#ifdef __STDC__ +SCM +scm_strftime (SCM format, SCM stime) +#else +SCM +scm_strftime (format, stime) + SCM format; + SCM stime; +#endif +{ + 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_sys_strptime, "%strptime", 2, 0, 0, scm_sys_strptime); +#ifdef __STDC__ +SCM +scm_sys_strptime (SCM format, SCM string) +#else +SCM +scm_sys_strptime (format, string) + SCM format; + SCM string; +#endif +{ +#ifdef HAVE_STRPTIME + SCM stime; + struct tm t; + + char *fmt, *str, *rest; + int len; + int n; + + SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, s_sys_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_sys_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) { + return SCM_BOOL_F; + } + + 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_wta (SCM_UNSPECIFIED, "strptime is not available and no replacement has (yet) been supplied", "strptime"); + return SCM_BOOL_F; +#endif +} + +SCM_PROC (s_sys_mknod, "%mknod", 3, 0, 0, scm_sys_mknod); +#ifdef __STDC__ +SCM +scm_sys_mknod(SCM path, SCM mode, SCM dev) +#else +SCM +scm_sys_mknod(path, mode, dev) + SCM path; + SCM mode; + SCM dev; +#endif +{ +#ifdef HAVE_MKNOD + int val; + SCM_ASSERT(SCM_NIMP(path) && SCM_STRINGP(path), path, SCM_ARG1, s_sys_mknod); + SCM_ASSERT(SCM_INUMP(mode), mode, SCM_ARG2, s_sys_mknod); + SCM_ASSERT(SCM_INUMP(dev), dev, SCM_ARG3, s_sys_mknod); + SCM_SYSCALL(val = mknod(SCM_CHARS(path), SCM_INUM(mode), SCM_INUM(dev))); + return val ? SCM_BOOL_F : SCM_BOOL_T; +#else + return SCM_BOOL_F; +#endif +} + + +SCM_PROC (s_sys_nice, "%nice", 1, 0, 0, scm_sys_nice); +#ifdef __STDC__ +SCM +scm_sys_nice(SCM incr) +#else +SCM +scm_sys_nice(incr) + SCM incr; +#endif +{ +#ifdef HAVE_NICE + SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_sys_nice); + return nice(SCM_INUM(incr)) ? SCM_MAKINUM (errno) : SCM_BOOL_T; +#else + return SCM_MAKINUM (ENOSYS); +#endif +} + + +SCM_PROC (s_sync, "sync", 0, 0, 0, scm_sync); +#ifdef __STDC__ +SCM +scm_sync(void) +#else +SCM +scm_sync() +#endif +{ +#ifdef HAVE_SYNC + sync(); +#endif + return SCM_UNSPECIFIED; +} + + + +#ifdef __STDC__ +void +scm_init_posix (void) +#else +void +scm_init_posix () +#endif +{ + 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 new file mode 100644 index 000000000..2bef059c8 --- /dev/null +++ b/libguile/posix.h @@ -0,0 +1,145 @@ +/* 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 "__scm.h" + + + + + +#ifdef __STDC__ +extern SCM scm_sys_pipe (void); +extern SCM scm_sys_getgroups(void); +extern SCM scm_sys_getpwuid (SCM user); +extern SCM scm_setpwent (SCM arg); +extern SCM scm_sys_getgrgid (SCM name); +extern SCM scm_setgrent (SCM arg); +extern SCM scm_sys_kill (SCM pid, SCM sig); +extern SCM scm_sys_waitpid (SCM pid, SCM options); +extern SCM scm_getppid (void); +extern SCM scm_getuid (void); +extern SCM scm_getgid (void); +extern SCM scm_geteuid (void); +extern SCM scm_getegid (void); +extern SCM scm_sys_setuid (SCM id); +extern SCM scm_sys_setgid (SCM id); +extern SCM scm_sys_seteuid (SCM id); +extern SCM scm_sys_setegid (SCM id); +extern SCM scm_ttyname (SCM port); +extern SCM scm_sys_execl (SCM args); +extern SCM scm_sys_execlp (SCM args); +extern SCM scm_sys_fork(void); +extern SCM scm_sys_uname (void); +extern SCM scm_environ (SCM env); +extern SCM scm_open_pipe (SCM pipestr, SCM modes); +extern SCM scm_open_input_pipe(SCM pipestr); +extern SCM scm_open_output_pipe(SCM pipestr); +extern SCM scm_sys_utime (SCM pathname, SCM actime, SCM modtime); +extern SCM scm_sys_access (SCM path, SCM how); +extern SCM scm_getpid (void); +extern SCM scm_sys_putenv (SCM str); +extern SCM scm_read_line (SCM port, SCM include_terminator); +extern SCM scm_read_line_x (SCM str, SCM port); +extern SCM scm_write_line (SCM obj, SCM port); +extern SCM scm_setlocale (SCM category, SCM locale); +extern SCM scm_strftime (SCM format, SCM stime); +extern SCM scm_sys_strptime (SCM format, SCM string); +extern SCM scm_sys_mknod(SCM path, SCM mode, SCM dev); +extern SCM scm_sys_nice(SCM incr); +extern SCM scm_sync(void); +extern void scm_init_posix (void); + +#else /* STDC */ +extern SCM scm_sys_pipe (); +extern SCM scm_sys_getgroups(); +extern SCM scm_sys_getpwuid (); +extern SCM scm_setpwent (); +extern SCM scm_sys_getgrgid (); +extern SCM scm_setgrent (); +extern SCM scm_sys_kill (); +extern SCM scm_sys_waitpid (); +extern SCM scm_getppid (); +extern SCM scm_getuid (); +extern SCM scm_getgid (); +extern SCM scm_geteuid (); +extern SCM scm_getegid (); +extern SCM scm_sys_setuid (); +extern SCM scm_sys_setgid (); +extern SCM scm_sys_seteuid (); +extern SCM scm_sys_setegid (); +extern SCM scm_ttyname (); +extern SCM scm_sys_execl (); +extern SCM scm_sys_execlp (); +extern SCM scm_sys_fork(); +extern SCM scm_sys_uname (); +extern SCM scm_environ (); +extern SCM scm_open_pipe (); +extern SCM scm_open_input_pipe(); +extern SCM scm_open_output_pipe(); +extern SCM scm_sys_utime (); +extern SCM scm_sys_access (); +extern SCM scm_getpid (); +extern SCM scm_sys_putenv (); +extern SCM scm_read_line (); +extern SCM scm_read_line_x (); +extern SCM scm_write_line (); +extern SCM scm_setlocale (); +extern SCM scm_strftime (); +extern SCM scm_sys_strptime (); +extern SCM scm_sys_mknod(); +extern SCM scm_sys_nice(); +extern SCM scm_sync(); +extern void scm_init_posix (); + +#endif /* STDC */ + + + + + + + +#endif /* POSIXH */ diff --git a/libguile/print.c b/libguile/print.c new file mode 100644 index 000000000..0877f2ace --- /dev/null +++ b/libguile/print.c @@ -0,0 +1,570 @@ +/* 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" + + + + + +/* {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>" +}; + + +/* {Printing of Scheme Objects} + */ + +/* Print generally. Handles both write and display according to WRITING. + */ +#ifdef __STDC__ +void +scm_iprin1 (SCM exp, SCM port, int writing) +#else +void +scm_iprin1 (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + 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, writing); + + } + else if ( SCM_IFLAGP (exp) + && (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *)))) + scm_gen_puts (scm_regular_string, SCM_ISYMSCM_CHARS (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 ", (scm_sizet) 9, port); + scm_intprint(exp, 16, port); + scm_gen_putc ('>', port); + break; + } + + case scm_tcs_cons_imcar: + case scm_tcs_cons_nimcar: + scm_iprlist ("(", exp, ')', port, writing); + break; + case scm_tcs_closures: +#ifdef DEBUG_EXTENSIONS + if (PRINT_PROCNAMES) + { + SCM name; + name = scm_procedure_property (exp, scm_i_name); + scm_gen_puts (scm_regular_string, "#<procedure", port); + if (SCM_NFALSEP (name)) + { + scm_gen_putc (' ', port); + /* FIXME */ + scm_gen_puts (scm_regular_string, SCM_CHARS (name), port); + } + scm_gen_putc ('>', port); + } + else +#endif + { + exp = SCM_CODE (exp); + scm_iprlist ("#<CLOSURE ", exp, '>', port, writing); + } + break; + case scm_tc7_mb_string: + case scm_tc7_mb_substring: + scm_print_mb_string (exp, port, writing); + break; + case scm_tc7_substring: + case scm_tc7_string: + if (writing) + { + 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; + + 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: + 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: + 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, writing); + scm_gen_putc (' ', port); + } + if (i < SCM_LENGTH (exp)) + { + /* CHECK_INTS; */ + scm_iprin1 (SCM_VELTS (exp)[i], port, writing); + } + scm_gen_putc (')', port); + 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, writing); + 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, writing); + 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, writing)) + break; + goto punk; + case scm_tc7_smob: + i = SCM_SMOBNUM (exp); + if (i < scm_numsmob && scm_smobs[i].print + && (scm_smobs[i].print) (exp, port, writing)) + break; + goto punk; + default: + punk:scm_ipruk ("type", exp, port); + } + } +} + + +/* Print an integer. + */ +#ifdef __STDC__ +void +scm_intprint (long n, int radix, SCM port) +#else +void +scm_intprint (n, radix, port) + long n; + int radix; + SCM port; +#endif +{ + 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. + */ +#ifdef __STDC__ +void +scm_ipruk (char *hdr, SCM ptr, SCM port) +#else +void +scm_ipruk (hdr, ptr, port) + char *hdr; + SCM ptr; + SCM port; +#endif +{ + 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. + */ +#ifdef __STDC__ +void +scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, int writing) +#else +void +scm_iprlist (hdr, exp, tlr, port, writing) + char *hdr; + SCM exp; + char tlr; + SCM port; + int writing; +#endif +{ + scm_gen_puts (scm_regular_string, hdr, port); + /* CHECK_INTS; */ + scm_iprin1 (SCM_CAR (exp), port, writing); + exp = SCM_CDR (exp); + for (; SCM_NIMP (exp); exp = SCM_CDR (exp)) + { + if (SCM_NECONSP (exp)) + break; + scm_gen_putc (' ', port); + /* CHECK_INTS; */ + scm_iprin1 (SCM_CAR (exp), port, writing); + } + if (SCM_NNULLP (exp)) + { + scm_gen_puts (scm_regular_string, " . ", port); + scm_iprin1 (exp, port, writing); + } + scm_gen_putc (tlr, port); +} + + + +SCM_PROC(s_write, "write", 1, 1, 0, scm_write); +#ifdef __STDC__ +SCM +scm_write (SCM obj, SCM port) +#else +SCM +scm_write (obj, port) + SCM obj; + SCM port; +#endif +{ + if (SCM_UNBNDP (port)) + port = scm_cur_outp; + else + SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write); + scm_iprin1 (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); +#ifdef __STDC__ +SCM +scm_display (SCM obj, SCM port) +#else +SCM +scm_display (obj, port) + SCM obj; + SCM port; +#endif +{ + if (SCM_UNBNDP (port)) + port = scm_cur_outp; + else + SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display); + scm_iprin1 (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); +#ifdef __STDC__ +SCM +scm_newline(SCM port) +#else +SCM +scm_newline (port) + SCM port; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_write_char (SCM chr, SCM port) +#else +SCM +scm_write_char (chr, port) + SCM chr; + SCM port; +#endif +{ + 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; +} + + + + +#ifdef __STDC__ +void +scm_init_print (void) +#else +void +scm_init_print () +#endif +{ +#include "print.x" +} + diff --git a/libguile/print.h b/libguile/print.h new file mode 100644 index 000000000..ae23eaf00 --- /dev/null +++ b/libguile/print.h @@ -0,0 +1,74 @@ +/* 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 "__scm.h" + + +#ifdef __STDC__ +extern void scm_intprint (long n, int radix, SCM port); +extern void scm_ipruk (char *hdr, SCM ptr, SCM port); +extern void scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, int writing); +extern void scm_iprin1 (SCM exp, SCM port, int writing); +extern SCM scm_write (SCM obj, SCM port); +extern SCM scm_display (SCM obj, SCM port); +extern SCM scm_newline(SCM port); +extern SCM scm_write_char (SCM chr, SCM port); +extern void scm_init_print (void); + +#else /* STDC */ +extern void scm_intprint (); +extern void scm_ipruk (); +extern void scm_iprlist (); +extern void scm_iprin1 (); +extern SCM scm_write (); +extern SCM scm_display (); +extern SCM scm_newline(); +extern SCM scm_write_char (); +extern void scm_init_print (); + +#endif /* STDC */ + +#endif /* PRINTH */ diff --git a/libguile/procprop.c b/libguile/procprop.c new file mode 100644 index 000000000..a984008db --- /dev/null +++ b/libguile/procprop.c @@ -0,0 +1,155 @@ +/* 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" + + + +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); +#ifdef __STDC__ +SCM +scm_procedure_properties (SCM proc) +#else +SCM +scm_procedure_properties (proc) + SCM proc; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_set_procedure_properties_x (SCM proc, SCM new_val) +#else +SCM +scm_set_procedure_properties_x (proc, new_val) + SCM proc; + SCM new_val; +#endif +{ + 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_PROCPROPS (proc) = new_val; + return SCM_UNSPECIFIED; +} + +SCM_PROC(s_procedure_property, "procedure-property", 2, 0, 0, scm_procedure_property); +#ifdef __STDC__ +SCM +scm_procedure_property (SCM p, SCM k) +#else +SCM +scm_procedure_property (p, k) + SCM p; + SCM k; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_set_procedure_property_x (SCM p, SCM k, SCM v) +#else +SCM +scm_set_procedure_property_x (p, k, v) + SCM p; + SCM k; + SCM v; +#endif +{ + 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_PROCPROPS (p) = scm_acons (k, v, SCM_PROCPROPS (p)); + return SCM_UNSPECIFIED; +} + + + +#ifdef __STDC__ +void +scm_init_procprop (void) +#else +void +scm_init_procprop () +#endif +{ +#include "procprop.x" +} + diff --git a/libguile/procprop.h b/libguile/procprop.h new file mode 100644 index 000000000..ee6f37cb3 --- /dev/null +++ b/libguile/procprop.h @@ -0,0 +1,72 @@ +/* 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 "__scm.h" + + + + + + +#ifdef __STDC__ +extern SCM scm_procedure_properties (SCM proc); +extern SCM scm_set_procedure_properties_x (SCM proc, SCM new_val); +extern SCM scm_procedure_property (SCM p, SCM k); +extern SCM scm_set_procedure_property_x (SCM p, SCM k, SCM v); +extern void scm_init_procprop (void); + +#else /* STDC */ +extern SCM scm_procedure_properties (); +extern SCM scm_set_procedure_properties_x (); +extern SCM scm_procedure_property (); +extern SCM scm_set_procedure_property_x (); +extern void scm_init_procprop (); + +#endif /* STDC */ + + + +#endif /* PROCPROPH */ diff --git a/libguile/procs.c b/libguile/procs.c new file mode 100644 index 000000000..6c5a5b2c4 --- /dev/null +++ b/libguile/procs.c @@ -0,0 +1,177 @@ +/* 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" + + + + + +/* {Procedures} + */ + +#ifdef __STDC__ +SCM +scm_make_subr_opt (char *name, int type, SCM (*fcn) (), int set) +#else +SCM +scm_make_subr_opt (name, type, fcn, set) + char *name; + int type; + SCM (*fcn) (); + int set; +#endif +{ + 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_CAR (z) = tmp + type; + if (set) + SCM_CDR (symcell) = z; + return z; +} + + +#ifdef __STDC__ +SCM +scm_make_subr (char *name, int type, SCM (*fcn) ()) +#else +SCM +scm_make_subr (name, type, fcn) + char *name; + int type; + SCM (*fcn) (); +#endif +{ + return scm_make_subr_opt (name, type, fcn, 1); +} + +#ifdef CCLO +#ifdef __STDC__ +SCM +scm_makcclo (SCM proc, long len) +#else +SCM +scm_makcclo (proc, len) + SCM proc; + long len; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_procedure_p (SCM obj) +#else +SCM +scm_procedure_p (obj) + SCM obj; +#endif +{ + 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; +} + + +#ifdef __STDC__ +void +scm_init_iprocs(scm_iproc *subra, int type) +#else +void +scm_init_iprocs(subra, type) + scm_iproc *subra; + int type; +#endif +{ + for(;subra->scm_string; subra++) + scm_make_subr(subra->scm_string, + type, + subra->cproc); +} + + + + +#ifdef __STDC__ +void +scm_init_procs (void) +#else +void +scm_init_procs () +#endif +{ +#include "procs.x" +} + diff --git a/libguile/procs.h b/libguile/procs.h new file mode 100644 index 000000000..332e06c1f --- /dev/null +++ b/libguile/procs.h @@ -0,0 +1,107 @@ +/* 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 "__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_SETCODE(x, e) SCM_CAR(x) = (scm_cons ((e), SCM_EOL) + scm_tc3_closure) +#define SCM_ENV(x) SCM_CDR(x) +#define SCM_TOP_LEVEL(SCM_ENV) (SCM_NULLP(SCM_ENV) || (SCM_BOOL_T == scm_procedure_p (SCM_CAR (SCM_ENV)))) + + + + +#ifdef __STDC__ +extern SCM scm_make_subr (char *name, int type, SCM (*fcn) ()); +extern SCM scm_makcclo (SCM proc, long len); +extern SCM scm_procedure_p (SCM obj); +extern void scm_init_iprocs(scm_iproc *subra, int type); +extern void scm_init_procs (void); + +#else /* STDC */ +extern SCM scm_make_subr (); +extern SCM scm_makcclo (); +extern SCM scm_procedure_p (); +extern void scm_init_iprocs(); +extern void scm_init_procs (); + +#endif /* STDC */ +#endif /* PROCSH */ diff --git a/libguile/ramap.c b/libguile/ramap.c new file mode 100644 index 000000000..a913da0e6 --- /dev/null +++ b/libguile/ramap.c @@ -0,0 +1,2229 @@ +/* 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" + + + +#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. */ + +#ifdef __STDC__ +static scm_sizet +cind (SCM ra, SCM inds) +#else +static scm_sizet +cind (ra, inds) + SCM ra; + SCM inds; +#endif +{ + 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. + */ +#ifdef __STDC__ +int +scm_ra_matchp (SCM ra0, SCM ras) +#else +int +scm_ra_matchp (ra0, ras) + SCM ra0; + SCM ras; +#endif +{ + 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"; + +#ifdef __STDC__ +int +scm_ramapc (int (*cproc) (), SCM data, SCM ra0, SCM lra, char *what) +#else +int +scm_ramapc (cproc, data, ra0, lra, what) + int (*cproc) (); + SCM data; + SCM ra0; + SCM lra; + char *what; +#endif +{ + 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_CDR (*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_CDR (*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[]; +#ifdef __STDC__ +int +scm_array_fill_int (SCM ra, SCM fill, SCM ignore) +#else +int +scm_array_fill_int (ra, fill, ignore) + SCM ra; + SCM fill; + SCM ignore; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_array_fill_x (SCM ra, SCM fill) +#else +SCM +scm_array_fill_x (ra, fill) + SCM ra; + SCM fill; +#endif +{ + scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, s_array_fill_x); + return SCM_UNSPECIFIED; +} + + + +#ifdef __STDC__ +static int +racp (SCM dst, SCM src) +#else +static int +racp (src, dst) + SCM dst; + SCM src; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_array_copy_x (SCM src, SCM dst) +#else +SCM +scm_array_copy_x (src, dst) + SCM src; + SCM dst; +#endif +{ + scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), s_array_copy_x); + return SCM_UNSPECIFIED; +} + +/* Functions callable by ARRAY-MAP! */ + +#ifdef __STDC__ +int +scm_ra_eqp (SCM ra0, SCM ras) +#else +int +scm_ra_eqp (ra0, ras) + SCM ra0; + SCM ras; +#endif +{ + 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 >= */ +#ifdef __STDC__ +static int +ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt) +#else +static int +ra_compare (ra0, ra1, ra2, opt) + SCM ra0; + SCM ra1; + SCM ra2; + int opt; +#endif +{ + 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; +} + + +#ifdef __STDC__ +int +scm_ra_lessp (SCM ra0, SCM ras) +#else +int +scm_ra_lessp (ra0, ras) + SCM ra0; + SCM ras; +#endif +{ + return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0); +} + +#ifdef __STDC__ +int +scm_ra_leqp (SCM ra0, SCM ras) +#else +int +scm_ra_leqp (ra0, ras) + SCM ra0; + SCM ras; +#endif +{ + return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1); +} + +#ifdef __STDC__ +int +scm_ra_grp (SCM ra0, SCM ras) +#else +int +scm_ra_grp (ra0, ras) + SCM ra0; + SCM ras; +#endif +{ + return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0); +} + +#ifdef __STDC__ +int +scm_ra_greqp (SCM ra0, SCM ras) +#else +int +scm_ra_greqp (ra0, ras) + SCM ra0; + SCM ras; +#endif +{ + return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1); +} + + +#ifdef __STDC__ +int +scm_ra_sum (SCM ra0, SCM ras) +#else +int +scm_ra_sum (ra0, ras) + SCM ra0; + SCM ras; +#endif +{ + 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; +} + + +#ifdef __STDC__ +int +scm_ra_difference (SCM ra0, SCM ras) +#else +int +scm_ra_difference (ra0, ras) + SCM ra0; + SCM ras; +#endif +{ + 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; +} + + +#ifdef __STDC__ +int +scm_ra_product (SCM ra0, SCM ras) +#else +int +scm_ra_product (ra0, ras) + SCM ra0; + SCM ras; +#endif +{ + 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; +} + +#ifdef __STDC__ +int +scm_ra_divide (SCM ra0, SCM ras) +#else +int +scm_ra_divide (ra0, ras) + SCM ra0; + SCM ras; +#endif +{ + 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; +} + +#ifdef __STDC__ +int +scm_array_identity (SCM src, SCM dst) +#else +int +scm_array_identity (dst, src) + SCM src; + SCM dst; +#endif +{ + return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL)); +} + + +#ifdef __STDC__ +static +int +ramap (SCM ra0, SCM proc, SCM ras) +#else +static int +ramap (ra0, proc, ras) + SCM ra0; + SCM proc; + SCM ras; +#endif +{ + 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; +} + +#ifdef __STDC__ +static int +ramap_cxr (SCM ra0, SCM proc, SCM ras) +#else +static int +ramap_cxr (ra0, proc, ras) + SCM ra0; + SCM proc; + SCM ras; +#endif +{ + 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; +} + + +#ifdef __STDC__ +static int +ramap_rp (SCM ra0, SCM proc, SCM ras) +#else +static int +ramap_rp (ra0, proc, ras) + SCM ra0; + SCM proc; + SCM ras; +#endif +{ + 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; +} + + +#ifdef __STDC__ +static int +ramap_1 (SCM ra0, SCM proc, SCM ras) +#else +static int +ramap_1 (ra0, proc, ras) + SCM ra0; + SCM proc; + SCM ras; +#endif +{ + 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; +} + + +#ifdef __STDC__ +static int +ramap_2o (SCM ra0, SCM proc, SCM ras) +#else +static int +ramap_2o (ra0, proc, ras) + SCM ra0; + SCM proc; + SCM ras; +#endif +{ + 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; +} + + +#ifdef __STDC__ +static int +ramap_a (SCM ra0, SCM proc, SCM ras) +#else +static int +ramap_a (ra0, proc, ras) + SCM ra0; + SCM proc; + SCM ras; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_array_map (SCM ra0, SCM proc, SCM lra) +#else +SCM +scm_array_map (ra0, proc, lra) + SCM ra0; + SCM proc; + SCM lra; +#endif +{ + 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; + } +} + +#ifdef __STDC__ +static int +rafe (SCM ra0, SCM proc, SCM ras) +#else +static int +rafe (ra0, proc, ras) + SCM ra0; + SCM proc; + SCM ras; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_array_for_each (SCM proc, SCM ra0, SCM lra) +#else +SCM +scm_array_for_each (proc, ra0, lra) + SCM proc; + SCM ra0; + SCM lra; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_array_index_map_x (SCM ra, SCM proc) +#else +SCM +scm_array_index_map_x (ra, proc) + SCM ra; + SCM proc; +#endif +{ + 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; + } + } +} + +#ifdef __STDC__ +static int +raeql_1 (SCM ra0, SCM as_equal, SCM ra1) +#else +static int +raeql_1 (ra0, as_equal, ra1) + SCM ra0; + SCM as_equal; + SCM ra1; +#endif +{ + 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 */ + } +} + + +#ifdef __STDC__ +static int +raeql (SCM ra0, SCM as_equal, SCM ra1) +#else +static int +raeql (ra0, as_equal, ra1) + SCM ra0; + SCM as_equal; + SCM ra1; +#endif +{ + 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), ""); +} + +#ifdef __STDC__ +SCM +scm_raequal (SCM ra0, SCM ra1) +#else +SCM +scm_raequal (ra0, ra1) + SCM ra0; + SCM ra1; +#endif +{ + return (raeql (ra0, SCM_BOOL_T, ra1) ? SCM_BOOL_T : SCM_BOOL_F); +} + +static char s_array_equal_p[] = "array-equal?"; + +#ifdef __STDC__ +SCM +scm_array_equal_p (SCM ra0, SCM ra1) +#else +SCM +scm_array_equal_p (ra0, ra1) + SCM ra0; + SCM ra1; +#endif +{ + 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))); +} + +#ifdef __STDC__ +void +scm_init_ramap (void) +#else +void +scm_init_ramap () +#endif +{ + 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 new file mode 100644 index 000000000..a198f59ee --- /dev/null +++ b/libguile/ramap.h @@ -0,0 +1,101 @@ +/* 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 "__scm.h" + + +#ifdef __STDC__ +extern int scm_ra_matchp (SCM ra0, SCM ras); +extern int scm_ramapc (int (*cproc) (), SCM data, SCM ra0, SCM lra, char *what); +extern int scm_array_fill_int (SCM ra, SCM fill, SCM ignore); +extern SCM scm_array_fill_x (SCM ra, SCM fill); +extern SCM scm_array_copy (SCM src, SCM dst); +extern int scm_ra_eqp (SCM ra0, SCM ras); +extern int scm_ra_lessp (SCM ra0, SCM ras); +extern int scm_ra_leqp (SCM ra0, SCM ras); +extern int scm_ra_grp (SCM ra0, SCM ras); +extern int scm_ra_greqp (SCM ra0, SCM ras); +extern int scm_ra_sum (SCM ra0, SCM ras); +extern int scm_ra_difference (SCM ra0, SCM ras); +extern int scm_ra_product (SCM ra0, SCM ras); +extern int scm_ra_divide (SCM ra0, SCM ras); +extern int scm_array_identity (SCM src, SCM dst); +extern SCM scm_array_map (SCM ra0, SCM proc, SCM lra); +extern SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra); +extern SCM scm_array_index_map_x (SCM ra, SCM proc); +extern SCM scm_raequal (SCM ra0, SCM ra1); +extern SCM scm_array_equal_p (SCM ra0, SCM ra1); +extern void scm_init_ramap (void); + +#else /* STDC */ +extern int scm_ra_matchp (); +extern int scm_ramapc (); +extern int scm_array_fill_int (); +extern SCM scm_array_fill_x (); +extern SCM scm_array_copy (); +extern int scm_ra_eqp (); +extern int scm_ra_lessp (); +extern int scm_ra_leqp (); +extern int scm_ra_grp (); +extern int scm_ra_greqp (); +extern int scm_ra_sum (); +extern int scm_ra_difference (); +extern int scm_ra_product (); +extern int scm_ra_divide (); +extern int scm_array_identity (); +extern SCM scm_array_map (); +extern SCM scm_array_for_each (); +extern SCM scm_array_index_map_x (); +extern SCM scm_raequal (); +extern SCM scm_array_equal_p (); +extern void scm_init_ramap (); + +#endif /* STDC */ + + + + +#endif /* RAMAPH */ diff --git a/libguile/read.c b/libguile/read.c new file mode 100644 index 000000000..1340fc1f4 --- /dev/null +++ b/libguile/read.c @@ -0,0 +1,597 @@ +/* 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 "read.h" + + + +#define default_case_i 0 + + + +SCM_PROC (s_read, "read", 0, 3, 0, scm_read); +#ifdef __STDC__ +SCM +scm_read (SCM port, SCM case_insensative_p, SCM sharp) +#else +SCM +scm_read (port, case_insensative_p, sharp) + SCM port; + SCM case_insensative_p; + SCM sharp; +#endif +{ + int c; + SCM tok_buf; + 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_insensative_p) + ? default_case_i + : (case_insensative_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); +} + + +#ifdef __STDC__ +char * +scm_grow_tok_buf (SCM * tok_buf) +#else +char * +scm_grow_tok_buf (tok_buf) + SCM * tok_buf; +#endif +{ + SCM t2; + scm_sizet len; + + len = SCM_LENGTH (*tok_buf); + len += (len / 2 ? len / 2 : 1); + t2 = scm_makstr (len, 0); + { + char * a; + char * b; + int l; + for (a = SCM_CHARS (*tok_buf), b = SCM_CHARS (t2), l = SCM_LENGTH (*tok_buf); + l; + --l, ++a, ++b) + *b = *a; + } + *tok_buf = t2; + return SCM_CHARS (*tok_buf); +} + + +#ifdef __STDC__ +int +scm_flush_ws (SCM port, char *eoferr) +#else +int +scm_flush_ws (port, eoferr) + SCM port; + char *eoferr; +#endif +{ + 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: + break; + case SCM_SINGLE_SPACES: + SCM_INCCOL (port); + break; + case '\t': + SCM_TABCOL (port); + break; + default: + return c; + } +} + + +#ifdef __STDC__ +int +scm_casei_streq (char * s1, char * s2) +#else +int +scm_casei_streq (s1, s2) + char * s1; + char * s2; +#endif +{ + while (*s1 && *s2) + if (scm_downcase((int)*s1) != scm_downcase((int)*s2)) + return 0; + else + { + ++s1; + ++s2; + } + return !(*s1 || *s2); +} + + +#ifdef __STDC__ +SCM +scm_lreadr (SCM * tok_buf, SCM port, int case_i, SCM sharp) +#else +SCM +scm_lreadr (tok_buf, port, case_i, sharp) + SCM * tok_buf; + SCM port; + int case_i; + SCM sharp; +#endif +{ + 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_lreadparen (tok_buf, port, "list", case_i, sharp); + + case ')': + scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read"); + goto tryagain; + + case '\'': + return scm_cons2 (scm_i_quote, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL); + + case '`': + return scm_cons2 (scm_i_quasiquote, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL); + + case ',': + c = scm_gen_getc (port); + if ('@' == c) + p = scm_i_uq_splicing; + else + { + scm_gen_ungetc (c, port); + p = scm_i_unquote; + } + return scm_cons2 (p, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL); + + case '#': + c = scm_gen_getc (port); + switch (c) + { + case '(': + p = scm_lreadparen (tok_buf, port, "vector", case_i, sharp); + 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 '*': + 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)) + { + SCM got; + got = scm_apply (sharp, SCM_MAKICHR (c), scm_acons (port, SCM_EOL, SCM_EOL)); + if (SCM_UNSPECIFIED == got) + goto unkshrp; + 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 +#ifdef __STDC__ +scm_sizet +scm_read_token (int ic, SCM * tok_buf, SCM port, int case_i, int weird) +#else +scm_sizet +scm_read_token (ic, * tok_buf, port, case_i, weird) + int ic; + SCM *tok_buf; + SCM port; + int case_i; + int weird; +#endif +{ + 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 + +#ifdef __STDC__ +SCM +scm_lreadparen (SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp) +#else +SCM +scm_lreadparen (tok_buf, port, name, case_i, sharp) + SCM *tok_buf; + SCM port; + char *name; + int case_i; + SCM sharp; +#endif +{ + 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))) + { + ans = scm_lreadr (tok_buf, port, case_i, sharp); + 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))) + { + SCM_CDR (tl) = scm_lreadr (tok_buf, port, case_i, sharp); + goto closeit; + } + tl = (SCM_CDR (tl) = scm_cons (tmp, SCM_EOL)); + } + return ans; +} + + + + + +#ifdef __STDC__ +void +scm_init_read (void) +#else +void +scm_init_read () +#endif +{ +#include "read.x" +} + diff --git a/libguile/read.h b/libguile/read.h new file mode 100644 index 000000000..edaea932b --- /dev/null +++ b/libguile/read.h @@ -0,0 +1,94 @@ +/* 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 "__scm.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' + + + +#ifdef __STDC__ +extern SCM scm_read (SCM port, SCM casep, SCM sharp); +extern char * scm_grow_tok_buf (SCM * tok_buf); +extern int scm_flush_ws (SCM port, char *eoferr); +extern int scm_casei_streq (char * s1, char * s2); +extern SCM scm_lreadr (SCM * tok_buf, SCM port, int case_i, SCM sharp); +extern scm_sizet scm_read_token (int ic, SCM * tok_buf, SCM port, int case_i, int weird); +extern SCM scm_lreadparen (SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp); +extern void scm_init_read (void); + +#else /* STDC */ +extern SCM scm_read (); +extern char * scm_grow_tok_buf (); +extern int scm_flush_ws (); +extern int scm_casei_streq (); +extern SCM scm_lreadr (); +extern scm_sizet scm_read_token (); +extern SCM scm_lreadparen (); +extern void scm_init_read (); + +#endif /* STDC */ + + +#endif /* READH */ diff --git a/libguile/root.c b/libguile/root.c new file mode 100644 index 000000000..9db2e9b18 --- /dev/null +++ b/libguile/root.c @@ -0,0 +1,101 @@ +/* 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" + + + +SCM scm_sys_protects[SCM_NUM_PROTECTS]; +struct scm_root_state the_scm_root; +struct scm_root_state * scm_root = &the_scm_root; + + + + + + + +/* 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 + + +#ifdef __STDC__ +SCM +scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void * closure) +#else +SCM +scm_call_catching_errors (thunk, err_filter, closure) + SCM (*thunk)(); + SCM (*err_filter)(); + void * closure; +#endif +{ + SCM answer; + setjmp_type i; + i = setjmp (SCM_JMPBUF (scm_rootcont)); + if (!i) + { + scm_gc_heap_lock = 0; + answer = thunk (closure); + } + else + { + scm_gc_heap_lock = 1; + answer = err_filter (scm_exitval, closure); + } + return answer; +} + + + + + diff --git a/libguile/root.h b/libguile/root.h new file mode 100644 index 000000000..370563dad --- /dev/null +++ b/libguile/root.h @@ -0,0 +1,138 @@ +/* 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 "__scm.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] +#define SCM_NUM_PROTECTS 15 + +extern SCM scm_sys_protects[]; + + + +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; + + 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_thunk_var; +}; + +#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) +#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_thunk_var (scm_root->top_level_lookup_thunk_var) +#define scm_system_transformer (scm_root->system_transformer) + + +extern struct scm_root_state * scm_root; + + + + +#ifdef __STDC__ +extern SCM scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void * closure); + +#else /* STDC */ +extern SCM scm_call_catching_errors (); + +#endif /* STDC */ + + + + + + +#endif /* ROOTH */ diff --git a/libguile/scmconfig.h.in b/libguile/scmconfig.h.in new file mode 100644 index 000000000..af237dbdc --- /dev/null +++ b/libguile/scmconfig.h.in @@ -0,0 +1,159 @@ +/* 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 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 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 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 setlocale function. */ +#undef HAVE_SETLOCALE + +/* 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 times function. */ +#undef HAVE_TIMES + +/* Define if you have the uname function. */ +#undef HAVE_UNAME + +/* Define if you have the <dirent.h> header file. */ +#undef HAVE_DIRENT_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/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 <time.h> header file. */ +#undef HAVE_TIME_H + +/* Define if you have the <unistd.h> header file. */ +#undef HAVE_UNISTD_H + +#undef SCM_SINGLES + +#undef SCM_STACK_GROWS_UP + diff --git a/libguile/scmhob.h b/libguile/scmhob.h new file mode 100644 index 000000000..127f4d5c1 --- /dev/null +++ b/libguile/scmhob.h @@ -0,0 +1,205 @@ +/* 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 "_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_int_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 CHAR_SCM_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_SCM_LENGTH(str) SCM_MAKINUM(SCM_LENGTH(str)) +#define ST_REF(str,k) SCM_MAKICHR(SCM_CHARS(str)[SCM_INUM(k)]) +#define VECTOR_SCM_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 new file mode 100644 index 000000000..bb7f740f9 --- /dev/null +++ b/libguile/scmsigs.c @@ -0,0 +1,397 @@ +/* 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" + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + + + + +#if (__TURBOC__==1) +#define signal ssignal /* Needed for TURBOC V1.0 */ +#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); +#ifdef __STDC__ +SCM +scm_alarm (SCM i) +#else +SCM +scm_alarm (i) + SCM i; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_pause (void) +#else +SCM +scm_pause () +#endif +{ + pause (); + return SCM_UNSPECIFIED; +} + +SCM_PROC(s_sleep, "sleep", 1, 0, 0, scm_sleep); +#ifdef __STDC__ +SCM +scm_sleep (SCM i) +#else +SCM +scm_sleep (i) + SCM i; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_raise(SCM sig) +#else +SCM +scm_raise(sig) + SCM sig; +#endif +{ + 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 + + +#ifdef __STDC__ +void +scm_init_signals (void) +#else +void +scm_init_signals () +#endif +{ +#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 */ +#ifdef __STDC__ +void +scm_ignore_signals (void) +#else +void +scm_ignore_signals () +#endif +{ +#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); +} + +#ifdef __STDC__ +void +scm_unignore_signals (void) +#else +void +scm_unignore_signals () +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_restore_signals (void) +#else +SCM +scm_restore_signals () +#endif +{ +#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; +} + + +#ifdef __STDC__ +void +scm_init_scmsigs (void) +#else +void +scm_init_scmsigs () +#endif +{ +#include "scmsigs.x" +} + diff --git a/libguile/scmsigs.h b/libguile/scmsigs.h new file mode 100644 index 000000000..484b15e9d --- /dev/null +++ b/libguile/scmsigs.h @@ -0,0 +1,79 @@ +/* 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. + */ + + + + +#ifdef __STDC__ +extern SCM scm_alarm (SCM i); +extern SCM scm_pause (void); +extern SCM scm_sleep (SCM i); +extern SCM scm_raise(SCM sig); +extern void scm_init_signals (void); +extern void scm_ignore_signals (void); +extern void scm_unignore_signals (void); +extern SCM scm_restore_signals (void); +extern void scm_init_scmsigs (void); + +#else /* STDC */ +extern SCM scm_alarm (); +extern SCM scm_pause (); +extern SCM scm_sleep (); +extern SCM scm_raise(); +extern void scm_init_signals (); +extern void scm_ignore_signals (); +extern void scm_unignore_signals (); +extern SCM scm_restore_signals (); +extern void scm_init_scmsigs (); + +#endif /* STDC */ + + + + + + + +#endif /* SCMSIGSH */ diff --git a/libguile/sequences.c b/libguile/sequences.c new file mode 100644 index 000000000..6973f74dc --- /dev/null +++ b/libguile/sequences.c @@ -0,0 +1,128 @@ +/* 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" + + + + + +#ifdef __STDC__ +int +scm_obj_length (SCM obj) +#else +int +scm_obj_length (obj) + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_length(SCM x) +#else +SCM +scm_length(x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_reverse (SCM objs) +#else +SCM +scm_reverse (objs) + SCM objs; +#endif +{ + return scm_list_reverse (objs); +} + + + + +#ifdef __STDC__ +void +scm_init_sequences (void) +#else +void +scm_init_sequences () +#endif +{ +#include "sequences.x" +} + diff --git a/libguile/sequences.h b/libguile/sequences.h new file mode 100644 index 000000000..a508daa9b --- /dev/null +++ b/libguile/sequences.h @@ -0,0 +1,70 @@ +/* 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 "__scm.h" + + + + + + +#ifdef __STDC__ +extern int scm_obj_length (SCM obj); +extern SCM scm_length(SCM x); +extern SCM scm_reverse (SCM objs); +extern void scm_init_sequences (void); + +#else /* STDC */ +extern int scm_obj_length (); +extern SCM scm_length(); +extern SCM scm_reverse (); +extern void scm_init_sequences (); + +#endif /* STDC */ + + + + +#endif /* SEQUENCESH */ diff --git a/libguile/simpos.c b/libguile/simpos.c new file mode 100644 index 000000000..f04e28cc5 --- /dev/null +++ b/libguile/simpos.c @@ -0,0 +1,163 @@ +/* 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" +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + + +extern int system(); + + +#ifndef _Windows +SCM_PROC(s_system, "system", 1, 0, 0, scm_system); +#ifdef __STDC__ +SCM +scm_system(SCM cmd) +#else +SCM +scm_system(cmd) + SCM cmd; +#endif +{ + 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_sys_getenv, "%getenv", 1, 0, 0, scm_sys_getenv); +#ifdef __STDC__ +SCM +scm_sys_getenv(SCM nam) +#else +SCM +scm_sys_getenv(nam) + SCM nam; +#endif +{ + char *val; + SCM_ASSERT(SCM_NIMP(nam) && SCM_ROSTRINGP(nam), nam, SCM_ARG1, s_sys_getenv); + if (SCM_ROSTRINGP (nam)) + nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0); + val = getenv(SCM_CHARS(nam)); + if (!val) + return SCM_BOOL_F; + return scm_makfromstr(val, (scm_sizet)strlen(val), 0); +} + +#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); +#ifdef __STDC__ +SCM +scm_software_type(void) +#else +SCM +scm_software_type() +#endif +{ +#ifdef nosve + return SCM_CAR(scm_intern("nosve", 5)); +#else + return SCM_CAR(scm_intern(SYSTNAME, sizeof SYSTNAME/sizeof(char) -1)); +#endif +} + +#ifdef __STDC__ +void +scm_init_simpos (void) +#else +void +scm_init_simpos () +#endif +{ +#include "simpos.x" +} + diff --git a/libguile/simpos.h b/libguile/simpos.h new file mode 100644 index 000000000..78cce68a5 --- /dev/null +++ b/libguile/simpos.h @@ -0,0 +1,67 @@ +/* classes: h_files */ + +#ifndef SSCM_IMPOSH +#define SSCM_IMPOSH +/* 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. + */ + + + + +#ifdef __STDC__ +extern SCM scm_system(SCM cmd); +extern SCM scm_sys_getenv(SCM nam); +extern SCM scm_software_type(void); +extern void scm_init_simpos (void); + +#else /* STDC */ +extern SCM scm_system(); +extern SCM scm_sys_getenv(); +extern SCM scm_software_type(); +extern void scm_init_simpos (); + +#endif /* STDC */ + + + + + +#endif /* SSCM_IMPOSH */ diff --git a/libguile/smob.c b/libguile/smob.c new file mode 100644 index 000000000..4843d486f --- /dev/null +++ b/libguile/smob.c @@ -0,0 +1,134 @@ +/* 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" +#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; + +#ifdef __STDC__ +long +scm_newsmob (scm_smobfuns *smob) +#else +long +scm_newsmob (smob) + scm_smobfuns *smob; +#endif +{ + 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 +}; + + + +#ifdef __STDC__ +void +scm_smob_prehistory (void) +#else +void +scm_smob_prehistory () +#endif +{ + 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 new file mode 100644 index 000000000..a35cefc27 --- /dev/null +++ b/libguile/smob.h @@ -0,0 +1,103 @@ +/* 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 "__scm.h" +#include "params.h" + + + + + +typedef struct scm_smobfuns +{ + SCM (*mark) SCM_P ((SCM)); + scm_sizet (*free) SCM_P ((SCM)); + int (*print) SCM_P ((SCM exp, SCM port, int writing)); + SCM (*equalp) SCM_P ((SCM, SCM)); +} scm_smobfuns; + +typedef struct scm_ptobfuns +{ + SCM (*mark) (); + int (*free) (); + int (*print) (); + SCM (*equalp) (); + int (*fputc) (); + int (*fputs) (); + scm_sizet (*fwrite) (); + int (*fflush) (); + int (*fgetc) (); + int (*fclose) (); + + + +} scm_ptobfuns; + + + + +#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; + + +#ifdef __STDC__ +extern long scm_newsmob (scm_smobfuns *smob); +extern void scm_smob_prehistory (void); + +#else /* STDC */ +extern long scm_newsmob (); +extern void scm_smob_prehistory (); + +#endif /* STDC */ + + + + + + +#endif /* SMOBH */ diff --git a/libguile/socket.c b/libguile/socket.c new file mode 100644 index 000000000..944609714 --- /dev/null +++ b/libguile/socket.c @@ -0,0 +1,408 @@ +/* "socket.c" internet socket support for client/server in SCM + Copyright (C) 1994 Aubrey Jaffer. + Thanks to Hallvard.Tretteberg@si.sintef.no + who credits NCSA httpd software by Rob McCool 3/21/93. + Rewritten by Gary Houston to be a closer interface to the C + socket library. + */ + + +#include <stdio.h> +#include <string.h> +#include "_scm.h" +#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 P ((int fd)); +#endif /* STDC_HEADERS */ + +SCM_PROC (s_sys_inet_aton, "%inet-aton", 1, 0, 0, scm_sys_inet_aton); +#ifdef __STDC__ +SCM +scm_sys_inet_aton (SCM address) +#else +SCM +scm_sys_inet_aton (address) + SCM address; +#endif +{ + struct in_addr soka; + int rv; + 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); + rv = inet_aton (SCM_ROCHARS (address), &soka); + return rv ? scm_ulong2num (ntohl (soka.s_addr)) : SCM_BOOL_F; +} + + +SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa); +#ifdef __STDC__ +SCM +scm_inet_ntoa (SCM inetid) +#else +SCM +scm_inet_ntoa (inetid) + SCM inetid; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_inet_netof (SCM address) +#else +SCM +scm_inet_netof (address) + SCM address; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_lnaof (SCM address) +#else +SCM +scm_lnaof (address) + SCM address; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_inet_makeaddr (SCM net, SCM lna) +#else +SCM +scm_inet_makeaddr (net, lna) + SCM net; + SCM lna; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_sys_gethost (SCM name) +#else +SCM +scm_sys_gethost (name) + SCM name; +#endif +{ + 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) + return SCM_BOOL_F; + 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); +#ifdef __STDC__ +SCM +scm_sys_getnet (SCM name) +#else +SCM +scm_sys_getnet (name) + SCM name; +#endif +{ + 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) + return SCM_BOOL_F; + 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); +#ifdef __STDC__ +SCM +scm_sys_getproto (SCM name) +#else +SCM +scm_sys_getproto (name) + SCM name; +#endif +{ + 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) + return SCM_BOOL_F; + 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; +} + +#ifdef __STDC__ +static SCM +scm_return_entry (struct servent *entry) +#else +static SCM +scm_return_entry (entry) + struct servent *entry; +#endif +{ + SCM ans; + SCM *ve; + + ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F); + ve = SCM_VELTS (ans); + if (!entry) + { + SCM_ALLOW_INTS; + return SCM_BOOL_F; + } + 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); +#ifdef __STDC__ +SCM +scm_sys_getserv (SCM name, SCM proto) +#else +SCM +scm_sys_getserv (name, proto) + SCM name; + SCM proto; +#endif +{ + struct servent *entry; + if (SCM_UNBNDP (name)) + { + SCM_DEFER_INTS; + entry = getservent (); + 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)); + } + return scm_return_entry (entry); +} + +SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost); +#ifdef __STDC__ +SCM +scm_sethost (SCM arg) +#else +SCM +scm_sethost (arg) + SCM arg; +#endif +{ + if (SCM_UNBNDP (arg)) + endhostent (); + else + sethostent (SCM_NFALSEP (arg)); + return SCM_UNSPECIFIED; +} + +SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet); +#ifdef __STDC__ +SCM +scm_setnet (SCM arg) +#else +SCM +scm_setnet (arg) + SCM arg; +#endif +{ + if (SCM_UNBNDP (arg)) + endnetent (); + else + setnetent (SCM_NFALSEP (arg)); + return SCM_UNSPECIFIED; +} + +SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto); +#ifdef __STDC__ +SCM +scm_setproto (SCM arg) +#else +SCM +scm_setproto (arg) + SCM arg; +#endif +{ + if (SCM_UNBNDP (arg)) + endprotoent (); + else + setprotoent (SCM_NFALSEP (arg)); + return SCM_UNSPECIFIED; +} + +SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv); +#ifdef __STDC__ +SCM +scm_setserv (SCM arg) +#else +SCM +scm_setserv (arg) + SCM arg; +#endif +{ + if (SCM_UNBNDP (arg)) + endservent (); + else + setservent (SCM_NFALSEP (arg)); + return SCM_UNSPECIFIED; +} + +#ifdef __STDC__ +void +scm_init_socket (void) +#else +void +scm_init_socket () +#endif +{ + scm_add_feature ("socket"); +#include "socket.x" +} + + diff --git a/libguile/socket.h b/libguile/socket.h new file mode 100644 index 000000000..28413a228 --- /dev/null +++ b/libguile/socket.h @@ -0,0 +1,119 @@ +/* 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 "__scm.h" + + + + + +#ifdef __STDC__ +extern SCM scm_sys_inet_aton (SCM address); +extern SCM scm_inet_ntoa (SCM inetid); +extern SCM scm_inet_netof (SCM address); +extern SCM scm_lnaof (SCM address); +extern SCM scm_inet_makeaddr (SCM net, SCM lna); +extern SCM scm_sys_getnet (SCM name); +extern SCM scm_sys_getproto (SCM name); +extern SCM scm_sys_getserv (SCM name, SCM proto); +extern SCM scm_sethost (SCM arg); +extern SCM scm_setnet (SCM arg); +extern SCM scm_setproto (SCM arg); +extern SCM scm_setserv (SCM arg); +extern SCM scm_sys_socket (SCM family, SCM style, SCM proto); +extern SCM scm_sys_socketpair (SCM family, SCM style, SCM proto); + +extern SCM scm_sys_getsockopt (SCM port, SCM level, SCM optname); +extern SCM scm_sys_setsockopt (SCM port, SCM level, SCM optname, SCM value); +extern SCM scm_sys_shutdown (SCM port, SCM how); +extern SCM scm_sys_connect (SCM sockpt, SCM fam, SCM address, SCM args); +extern SCM scm_sys_bind (SCM sockpt, SCM fam, SCM address); +extern SCM scm_sys_listen (SCM port, SCM backlog); +extern void scm_init_addr_buffer (void); +extern SCM scm_sys_accept (SCM sockpt); +extern SCM scm_sys_getsockname (SCM sockpt); +extern SCM scm_sys_getpeername (SCM sockpt); +extern SCM scm_sys_recv (SCM sockpt, SCM buff_or_size, SCM flags); +extern SCM scm_sys_send (SCM sockpt, SCM message, SCM flags); +extern SCM scm_sys_recvfrom (SCM sockpt, SCM buff_or_size, SCM flags); +extern SCM scm_sys_sendto (SCM sockpt, SCM message, SCM fam, SCM address, SCM args_and_flags); +extern void scm_init_socket (void); + +#else /* STDC */ +extern SCM scm_sys_inet_aton (); +extern SCM scm_inet_ntoa (); +extern SCM scm_inet_netof (); +extern SCM scm_lnaof (); +extern SCM scm_inet_makeaddr (); +extern SCM scm_sys_getnet (); +extern SCM scm_sys_getproto (); +extern SCM scm_sys_getserv (); +extern SCM scm_sethost (); +extern SCM scm_setnet (); +extern SCM scm_setproto (); +extern SCM scm_setserv (); +extern SCM scm_sys_socket (); +extern SCM scm_sys_socketpair (); +extern SCM scm_sys_getsockopt (); +extern SCM scm_sys_setsockopt (); +extern SCM scm_sys_shutdown (); +extern SCM scm_sys_connect (); +extern SCM scm_sys_bind (); +extern SCM scm_sys_listen (); +extern void scm_init_addr_buffer (); +extern SCM scm_sys_accept (); +extern SCM scm_sys_getsockname (); +extern SCM scm_sys_getpeername (); +extern SCM scm_sys_recv (); +extern SCM scm_sys_send (); +extern SCM scm_sys_recvfrom (); +extern SCM scm_sys_sendto (); +extern void scm_init_socket (); + +#endif /* STDC */ + + +#endif /* SOCKETH */ diff --git a/libguile/stackchk.c b/libguile/stackchk.c new file mode 100644 index 000000000..53a7556be --- /dev/null +++ b/libguile/stackchk.c @@ -0,0 +1,112 @@ +/* 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" + + + +/* {Stack Checking} + */ + +#ifdef SCM_STACK_CHECK +int scm_check_stack_p; + +void +scm_report_stack_overflow () +{ + scm_check_stack_p = 0; + scm_wta (SCM_UNDEFINED, (char *) STACK_SCM_OVSCM_FLOW, NULL); +} + +#endif +#ifdef __STDC__ +long +scm_stack_size (SCM_STACKITEM *start) +#else +long +scm_stack_size (start) + SCM_STACKITEM *start; +#endif +{ + SCM_STACKITEM stack; +#ifdef SCM_STACK_GROWS_UP + return &stack - start; +#else + return start - &stack; +#endif /* def SCM_STACK_GROWS_UP */ +} + +#ifdef __STDC__ +void +scm_stack_report (void) +#else +void +scm_stack_report () +#endif +{ + 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); +} + + + +#ifdef __STDC__ +void +scm_init_stackchk (void) +#else +void +scm_init_stackchk () +#endif +{ +#ifdef SCM_STACK_CHECK + scm_check_stack_p = 1; +#endif +#include "stackchk.x" +} + diff --git a/libguile/stackchk.h b/libguile/stackchk.h new file mode 100644 index 000000000..eb3c436a2 --- /dev/null +++ b/libguile/stackchk.h @@ -0,0 +1,90 @@ +/* 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 "__scm.h" + + + +#ifdef SCM_STACK_LIMIT +# define SCM_STACK_CHECK +# ifdef SCM_STACK_GROWS_UP +# define SCM_STACK_OVERFLOW_P(s) (s - SCM_BASE (rootcont) > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM)) +# else +# define SCM_STACK_OVERFLOW_P(s) (SCM_BASE (rootcont) - s > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM)) +# endif +# define SCM_CHECK_STACK\ + {\ + SCM_STACKITEM stack;\ + if (SCM_STACK_OVERFLOW_P (&stack) && scm_check_stack_p)\ + scm_report_stack_overflow ();\ + } +#else +# define SCM_CHECK_STACK /**/ +#endif /* def SCM_STACK_LIMIT */ + + +extern int scm_check_stack_p; + + +#ifdef __STDC__ +extern long scm_stack_size (SCM_STACKITEM *start); +extern void scm_stack_report (void); +extern void scm_init_stackchk (void); + +#else /* STDC */ +extern long scm_stack_size (); +extern void scm_stack_report (); +extern void scm_init_stackchk (); + +#endif /* STDC */ + + + + + + + + +#endif /* STACKCHKH */ diff --git a/libguile/stime.c b/libguile/stime.c new file mode 100644 index 000000000..77ead9a7a --- /dev/null +++ b/libguile/stime.c @@ -0,0 +1,236 @@ +/* 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" +#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 +#ifdef __STDC__ +static +long mytime(void) +#else +static +long mytime() +#endif +{ + 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 + +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); +#ifdef __STDC__ +SCM +scm_get_internal_real_time(void) +#else +SCM +scm_get_internal_real_time() +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_get_internal_real_time(void) +#else +SCM +scm_get_internal_real_time() +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_get_internal_run_time(void) +#else +SCM +scm_get_internal_run_time() +#endif +{ + return SCM_MAKINUM(mytime()-scm_my_base); +} + +SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time); +#ifdef __STDC__ +SCM +scm_current_time(void) +#else +SCM +scm_current_time() +#endif +{ + timet timv = time((timet*)0); + SCM ans; + ans = scm_ulong2num(timv); + return SCM_BOOL_F==ans ? SCM_MAKINUM(timv) : ans; +} + +#ifdef __STDC__ +long +scm_time_in_msec(long x) +#else +long +scm_time_in_msec(x) + long x; +#endif +{ + if (CLKTCK==60) return (x*50)/3; + else + return (CLKTCK < 1000 ? x*(1000L/(long)CLKTCK) : (x*1000L)/(long)CLKTCK); +} + +#ifdef __STDC__ +void +scm_init_stime(void) +#else +void +scm_init_stime() +#endif +{ + 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 new file mode 100644 index 000000000..c492d40fe --- /dev/null +++ b/libguile/stime.h @@ -0,0 +1,75 @@ +/* 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 "__scm.h" + + +#ifdef __STDC__ +extern SCM scm_get_internal_real_time(void); +extern SCM scm_get_internal_real_time(void); +extern SCM scm_get_internal_real_time(void); +extern SCM scm_get_internal_run_time(void); +extern SCM scm_current_time(void); +extern long scm_time_in_msec(long x); +extern void scm_init_stime(void); + +#else /* STDC */ +extern SCM scm_get_internal_real_time(); +extern SCM scm_get_internal_real_time(); +extern SCM scm_get_internal_real_time(); +extern SCM scm_get_internal_run_time(); +extern SCM scm_current_time(); +extern long scm_time_in_msec(); +extern void scm_init_stime(); + +#endif /* STDC */ + + + + + + +#endif /* TIMEH */ diff --git a/libguile/strings.c b/libguile/strings.c new file mode 100644 index 000000000..ea96e8c30 --- /dev/null +++ b/libguile/strings.c @@ -0,0 +1,473 @@ +/* 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" + + + +/* {Strings} + */ + +SCM_PROC(s_string_p, "string?", 1, 0, 0, scm_string_p); +#ifdef __STDC__ +SCM +scm_string_p (SCM x) +#else +SCM +scm_string_p (x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_read_only_string_p (SCM x) +#else +SCM +scm_read_only_string_p (x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string (SCM chrs) +#else +SCM +scm_string (chrs) + SCM chrs; +#endif +{ + SCM res; + register 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_CHARS (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_ROCHARS (SCM_CAR (chrs)); + while (l) + { + --l; + *data++ = *c++; + } + } + } + SCM_ALLOW_INTS; + return res; +} + +#ifdef __STDC__ +SCM +scm_makstr (long len, int slots) +#else +SCM +scm_makstr (len, slots) + long len; + int slots; +#endif +{ + 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. */ +#ifdef __STDC__ +SCM +scm_makfromstrs (int argc, char **argv) +#else +SCM +scm_makfromstrs (argc, argv) + int argc; + char **argv; +#endif +{ + 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; +} + + +#ifdef __STDC__ +SCM +scm_take0str (char * it) +#else +SCM +scm_take0str (it) + char * it; +#endif +{ + 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; +} + +#ifdef __STDC__ +SCM +scm_makfromstr (const char *src, scm_sizet len, int slots) +#else +SCM +scm_makfromstr (src, len, slots) + const char *src; + scm_sizet len; + int slots; +#endif +{ + SCM s; + register char *dst; + s = scm_makstr ((long) len, slots); + dst = SCM_CHARS (s); + while (len--) + *dst++ = *src++; + return s; +} + + +#ifdef __STDC__ +SCM +scm_makfrom0str (char *src) +#else +SCM +scm_makfrom0str (src) + char *src; +#endif +{ + if (!src) return SCM_BOOL_F; + return scm_makfromstr (src, (scm_sizet) strlen (src), 0); +} + +#ifdef __STDC__ +SCM +scm_makfrom0str_opt (char *src) +#else +SCM +scm_makfrom0str_opt (src) + char *src; +#endif +{ + return scm_makfrom0str (src); +} + + + + +SCM_PROC(s_make_string, "make-string", 1, 1, 0, scm_make_string); +#ifdef __STDC__ +SCM +scm_make_string (SCM k, SCM chr) +#else +SCM +scm_make_string (k, chr) + SCM k; + SCM chr; +#endif +{ + SCM res; + register 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_CHARS (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); +#ifdef __STDC__ +SCM +scm_string_length (SCM str) +#else +SCM +scm_string_length (str) + SCM str; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_ref (SCM str, SCM k) +#else +SCM +scm_string_ref (str, k) + SCM str; + SCM k; +#endif +{ + 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_ROCHARS (str)[SCM_INUM (k)]); +} + +SCM_PROC(s_string_set_x, "string-set!", 3, 0, 0, scm_string_set_x); +#ifdef __STDC__ +SCM +scm_string_set_x (SCM str, SCM k, SCM chr) +#else +SCM +scm_string_set_x (str, k, chr) + SCM str; + SCM k; + SCM chr; +#endif +{ + 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_CHARS (str)[SCM_INUM (k)] = SCM_ICHR (chr); + return SCM_UNSPECIFIED; +} + + + +SCM_PROC(s_substring, "substring", 2, 1, 0, scm_substring); +#ifdef __STDC__ +SCM +scm_substring (SCM str, SCM start, SCM end) +#else +SCM +scm_substring (str, start, end) + SCM str; + SCM start; + SCM end; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_append (SCM args) +#else +SCM +scm_string_append (args) + SCM args; +#endif +{ + SCM res; + register long i = 0; + register SCM l, s; + register 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_CHARS (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_ROCHARS (s)[i]; + } + return res; +} + +SCM_PROC(s_make_shared_substring, "make-shared-substring", 1, 2, 0, scm_make_shared_substring); +#ifdef __STDC__ +SCM +scm_make_shared_substring (SCM str, SCM frm, SCM to) +#else +SCM +scm_make_shared_substring (str, frm, to) + SCM str; + SCM frm; + SCM to; +#endif +{ + 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; +} + +#ifdef __STDC__ +void +scm_init_strings (void) +#else +void +scm_init_strings () +#endif +{ +#include "strings.x" +} + diff --git a/libguile/strings.h b/libguile/strings.h new file mode 100644 index 000000000..6615e2330 --- /dev/null +++ b/libguile/strings.h @@ -0,0 +1,109 @@ +/* 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 "__scm.h" + + + +#define SCM_STRINGP(x) (SCM_TYP7S(x)==scm_tc7_string) +#define SCM_NSTRINGP(x) (!SCM_STRINGP(x)) + + + +#ifdef __STDC__ +extern SCM scm_string_p (SCM x); +extern SCM scm_read_only_string_p (SCM x); +extern SCM scm_string (SCM chrs); +extern SCM scm_makstr (long len, int slots); +extern SCM scm_makfromstrs (int argc, char **argv); +extern SCM scm_take0str (char * it); +extern SCM scm_makfromstr (const char *src, scm_sizet len, int slots); +extern SCM scm_makfrom0str (char *src); +extern SCM scm_makfrom0str_opt (char *src); +extern SCM scm_make_string (SCM k, SCM chr); +extern SCM scm_string_length (SCM str); +extern SCM scm_string_ref (SCM str, SCM k); +extern SCM scm_string_set_x (SCM str, SCM k, SCM chr); +extern SCM scm_substring (SCM str, SCM start, SCM end); +extern SCM scm_string_append (SCM args); +extern SCM scm_make_shared_substring (SCM str, SCM frm, SCM to); +extern void scm_init_strings (void); + +#else /* STDC */ +extern SCM scm_string_p (); +extern SCM scm_read_only_string_p (); +extern SCM scm_string (); +extern SCM scm_makstr (); +extern SCM scm_makfromstrs (); +extern SCM scm_take0str (); +extern SCM scm_makfromstr (); +extern SCM scm_makfrom0str (); +extern SCM scm_makfrom0str_opt (); +extern SCM scm_make_string (); +extern SCM scm_string_length (); +extern SCM scm_string_ref (); +extern SCM scm_string_set_x (); +extern SCM scm_substring (); +extern SCM scm_string_append (); +extern SCM scm_make_shared_substring (); +extern void scm_init_strings (); + +#endif /* STDC */ + + + + + + + + + + + + + + +#endif /* STRINGSH */ diff --git a/libguile/strop.c b/libguile/strop.c new file mode 100644 index 000000000..366d249da --- /dev/null +++ b/libguile/strop.c @@ -0,0 +1,368 @@ +/* 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" + + + +#ifdef __STDC__ +int +scm_i_index (SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why) +#else +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; +#endif +{ + 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; +} + +#ifdef __STDC__ +int +scm_i_rindex (SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why) +#else +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; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_index (SCM str, SCM chr, SCM frm, SCM to) +#else +SCM +scm_string_index (str, chr, frm, to) + SCM str; + SCM chr; + SCM frm; + SCM to; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to) +#else +SCM +scm_string_rindex (str, chr, frm, to) + SCM str; + SCM chr; + SCM frm; + SCM to; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_substring_move_left_x (SCM str1, SCM start1, SCM args) +#else +SCM +scm_substring_move_left_x (str1, start1, args) + SCM str1; + SCM start1; + SCM args; +#endif +{ + SCM end1, str2, start2; + long i, j, e; + SCM_ASSERT (3==scm_ilength (args), args, SCM_WNA, s_substring_move_left_x); + 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); +#ifdef __STDC__ +SCM +scm_substring_move_right_x (SCM str1, SCM start1, SCM args) +#else +SCM +scm_substring_move_right_x (str1, start1, args) + SCM str1; + SCM start1; + SCM args; +#endif +{ + SCM end1, str2, start2; + long i, j, e; + SCM_ASSERT (3==scm_ilength (args), args, SCM_WNA, s_substring_move_right_x); + 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); +#ifdef __STDC__ +SCM +scm_substring_fill_x (SCM str, SCM start, SCM args) +#else +SCM +scm_substring_fill_x (str, start, args) + SCM str; + SCM start; + SCM args; +#endif +{ + SCM end, fill; + long i, e; + char c; + SCM_ASSERT (2==scm_ilength (args), args, SCM_WNA, s_substring_fill_x); + 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); +#ifdef __STDC__ +SCM +scm_string_null_p (SCM str) +#else +SCM +scm_string_null_p (str) + SCM str; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_to_list (SCM str) +#else +SCM +scm_string_to_list (str) + SCM str; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_copy (SCM str) +#else +SCM +scm_string_copy (str) + SCM str; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_fill_x (SCM str, SCM chr) +#else +SCM +scm_string_fill_x (str, chr) + SCM str; + SCM chr; +#endif +{ + 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; +} + + +#ifdef __STDC__ +void +scm_init_strop (void) +#else +void +scm_init_strop () +#endif +{ +#include "strop.x" +} + diff --git a/libguile/strop.h b/libguile/strop.h new file mode 100644 index 000000000..d2b9a9c00 --- /dev/null +++ b/libguile/strop.h @@ -0,0 +1,89 @@ +/* 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 "__scm.h" + + + +#ifdef __STDC__ +extern int scm_i_index (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 * 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 str, SCM chr, SCM frm, SCM to); +extern SCM scm_string_rindex (SCM str, SCM chr, SCM frm, SCM to); +extern SCM scm_substring_move_left_x (SCM str1, SCM start1, SCM args); +extern SCM scm_substring_move_right_x (SCM str1, SCM start1, SCM args); +extern SCM scm_substring_fill_x (SCM str, SCM start, SCM args); +extern SCM scm_string_null_p (SCM str); +extern SCM scm_string_to_list (SCM str); +extern SCM scm_string_copy (SCM str); +extern SCM scm_string_fill_x (SCM str, SCM chr); +extern void scm_init_strop (void); + +#else /* STDC */ +extern int scm_i_index (); +extern int scm_i_rindex (); +extern SCM scm_string_index (); +extern SCM scm_string_rindex (); +extern SCM scm_substring_move_left_x (); +extern SCM scm_substring_move_right_x (); +extern SCM scm_substring_fill_x (); +extern SCM scm_string_null_p (); +extern SCM scm_string_to_list (); +extern SCM scm_string_copy (); +extern SCM scm_string_fill_x (); +extern void scm_init_strop (); + +#endif /* STDC */ + + + + + + + + + +#endif /* STROPH */ diff --git a/libguile/strorder.c b/libguile/strorder.c new file mode 100644 index 000000000..5e1a15a26 --- /dev/null +++ b/libguile/strorder.c @@ -0,0 +1,266 @@ +/* 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" + + + +SCM_PROC1 (s_string_equal_p, "string=?", scm_tc7_rpsubr, scm_string_equal_p); +#ifdef __STDC__ +SCM +scm_string_equal_p (SCM s1, SCM s2) +#else +SCM +scm_string_equal_p (s1, s2) + SCM s1; + SCM s2; +#endif +{ + register scm_sizet i; + register 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_ROCHARS (s1); + c2 = SCM_ROCHARS (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); +#ifdef __STDC__ +SCM +scm_string_ci_equal_p (SCM s1, SCM s2) +#else +SCM +scm_string_ci_equal_p (s1, s2) + SCM s1; + SCM s2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_less_p (SCM s1, SCM s2) +#else +SCM +scm_string_less_p (s1, s2) + SCM s1; + SCM s2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_leq_p (SCM s1, SCM s2) +#else +SCM +scm_string_leq_p (s1, s2) + SCM s1; + SCM s2; +#endif +{ + return SCM_BOOL_NOT (scm_string_less_p (s2, s1)); +} + +SCM_PROC1 (s_string_gr_p, "string>?", scm_tc7_rpsubr, scm_string_gr_p); +#ifdef __STDC__ +SCM +scm_string_gr_p (SCM s1, SCM s2) +#else +SCM +scm_string_gr_p (s1, s2) + SCM s1; + SCM s2; +#endif +{ + return scm_string_less_p (s2, s1); +} + +SCM_PROC1 (s_string_geq_p, "string>=?", scm_tc7_rpsubr, scm_string_geq_p); +#ifdef __STDC__ +SCM +scm_string_geq_p (SCM s1, SCM s2) +#else +SCM +scm_string_geq_p (s1, s2) + SCM s1; + SCM s2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_ci_less_p (SCM s1, SCM s2) +#else +SCM +scm_string_ci_less_p (s1, s2) + SCM s1; + SCM s2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_ci_leq_p (SCM s1, SCM s2) +#else +SCM +scm_string_ci_leq_p (s1, s2) + SCM s1; + SCM s2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_ci_gr_p (SCM s1, SCM s2) +#else +SCM +scm_string_ci_gr_p (s1, s2) + SCM s1; + SCM s2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_ci_geq_p (SCM s1, SCM s2) +#else +SCM +scm_string_ci_geq_p (s1, s2) + SCM s1; + SCM s2; +#endif +{ + return SCM_BOOL_NOT (scm_string_ci_less_p (s1, s2)); +} + + +#ifdef __STDC__ +void +scm_init_strorder (void) +#else +void +scm_init_strorder () +#endif +{ +#include "strorder.x" +} + diff --git a/libguile/strorder.h b/libguile/strorder.h new file mode 100644 index 000000000..ebc4a8de8 --- /dev/null +++ b/libguile/strorder.h @@ -0,0 +1,85 @@ +/* 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 "__scm.h" + + + + + + + +#ifdef __STDC__ +extern SCM scm_string_equal_p (SCM s1, SCM s2); +extern SCM scm_string_ci_equal_p (SCM s1, SCM s2); +extern SCM scm_string_less_p (SCM s1, SCM s2); +extern SCM scm_string_leq_p (SCM s1, SCM s2); +extern SCM scm_string_gr_p (SCM s1, SCM s2); +extern SCM scm_string_geq_p (SCM s1, SCM s2); +extern SCM scm_string_ci_less_p (SCM s1, SCM s2); +extern SCM scm_string_ci_leq_p (SCM s1, SCM s2); +extern SCM scm_string_ci_gr_p (SCM s1, SCM s2); +extern SCM scm_string_ci_geq_p (SCM s1, SCM s2); +extern void scm_init_strorder (void); + +#else /* STDC */ +extern SCM scm_string_equal_p (); +extern SCM scm_string_ci_equal_p (); +extern SCM scm_string_less_p (); +extern SCM scm_string_leq_p (); +extern SCM scm_string_gr_p (); +extern SCM scm_string_geq_p (); +extern SCM scm_string_ci_less_p (); +extern SCM scm_string_ci_leq_p (); +extern SCM scm_string_ci_gr_p (); +extern SCM scm_string_ci_geq_p (); +extern void scm_init_strorder (); + +#endif /* STDC */ + + + +#endif /* STRORDERH */ diff --git a/libguile/strports.c b/libguile/strports.c new file mode 100644 index 000000000..1ba808a51 --- /dev/null +++ b/libguile/strports.c @@ -0,0 +1,285 @@ +/* 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" + + + +/* {Ports - string ports} + * + */ + +#ifdef __STDC__ +static int +prinstpt (SCM exp, SCM port, int writing) +#else +static int +prinstpt (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + scm_prinport (exp, port, "string"); + return !0; +} + +#ifdef __STDC__ +static int +stputc (int c, SCM p) +#else +static int +stputc (c, p) + int c; + SCM p; +#endif +{ + 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_CAR (p) = SCM_MAKINUM (ind + 1); + return c; +} + +#ifdef __STDC__ +static scm_sizet +stwrite (char *str, scm_sizet siz, scm_sizet num, SCM p) +#else +static scm_sizet +stwrite (str, siz, num, p) + char *str; + scm_sizet siz; + scm_sizet num; + SCM p; +#endif +{ + 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_CAR (p) = SCM_MAKINUM (ind + siz * num); + return num; +} + +#ifdef __STDC__ +static int +stputs (char *s, SCM p) +#else +static int +stputs (s, p) + char *s; + SCM p; +#endif +{ + stwrite (s, 1, strlen (s), p); + return 0; +} + +#ifdef __STDC__ +static int +stgetc (SCM p) +#else +static int +stgetc (p) + SCM p; +#endif +{ + scm_sizet ind = SCM_INUM (SCM_CAR (p)); + if (ind >= SCM_ROLENGTH (SCM_CDR (p))) + return EOF; + SCM_CAR (p) = SCM_MAKINUM (ind + 1); + return SCM_ROUCHARS (SCM_CDR (p))[ind]; +} + +#ifdef __STDC__ +SCM +scm_mkstrport (SCM pos, SCM str, long modes, char * caller) +#else +SCM +scm_mkstrport (pos, str, modes, caller) + SCM pos; + SCM str; + long modes; + char * caller; +#endif +{ + 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_CAR (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); +#ifdef __STDC__ +SCM +scm_call_with_output_string (SCM proc) +#else +SCM +scm_call_with_output_string (proc) + SCM proc; +#endif +{ + 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. + */ + +#ifdef __STDC__ +SCM +scm_strprint_obj (SCM obj) +#else +SCM +scm_strprint_obj (obj) + SCM obj; +#endif +{ + SCM str; + SCM port; + + str = scm_makstr (64, 0); + port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj"); + scm_iprin1 (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); +#ifdef __STDC__ +SCM +scm_call_with_input_string (SCM str, SCM proc) +#else +SCM +scm_call_with_input_string (str, proc) + SCM str; + SCM proc; +#endif +{ + SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, s_call_with_input_string); + return scm_apply (proc, p, scm_listofnull); +} + +#ifdef __STDC__ +static int +noop0 (FILE *stream) +#else +static int +noop0 (stream) + FILE *stream; +#endif +{ + return 0; +} + + +scm_ptobfuns scm_stptob = +{ + scm_markstream, + noop0, + prinstpt, + 0, + stputc, + stputs, + stwrite, + noop0, + stgetc, + 0 +}; + + +#ifdef __STDC__ +void +scm_init_strports (void) +#else +void +scm_init_strports () +#endif +{ +#include "strports.x" +} + diff --git a/libguile/strports.h b/libguile/strports.h new file mode 100644 index 000000000..2eb01961e --- /dev/null +++ b/libguile/strports.h @@ -0,0 +1,75 @@ +/* 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 "__scm.h" + +extern scm_ptobfuns scm_stptob; + + +#ifdef __STDC__ +extern SCM scm_mkstrport (SCM pos, SCM str, long modes, char * caller); +extern SCM scm_call_with_output_string (SCM proc); +extern SCM scm_strprint_obj (SCM obj); +extern SCM scm_call_with_input_string (SCM str, SCM proc); +extern void scm_init_strports (void); + +#else /* STDC */ +extern SCM scm_mkstrport (); +extern SCM scm_call_with_output_string (); +extern SCM scm_strprint_obj (); +extern SCM scm_call_with_input_string (); +extern void scm_init_strports (); + +#endif /* STDC */ + + + + + + + + +#endif /* STRPORTSH */ diff --git a/libguile/struct.c b/libguile/struct.c new file mode 100644 index 000000000..265c7d4fd --- /dev/null +++ b/libguile/struct.c @@ -0,0 +1,548 @@ +/* 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" + + + +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); +#ifdef __STDC__ +SCM +scm_make_struct_layout (SCM fields) +#else +SCM +scm_make_struct_layout (fields) + SCM fields; +#endif +{ + 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; + 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); +} + + + + +#ifdef __STDC__ +static void +init_struct (SCM handle, SCM tail_elts, SCM inits) +#else +static void +init_struct (handle, tail_elts, inits) + SCM handle; + SCM tail_elts; + SCM inits; +#endif +{ + SCM layout; + SCM * data; + unsigned char * fields_desc; + int n_fields; + SCM * mem; + + layout = SCM_STRUCT_LAYOUT (handle); + data = SCM_STRUCT_DATA (handle); + fields_desc = (unsigned char *)SCM_CHARS (layout); + n_fields = SCM_LENGTH (layout) / 2; + mem = SCM_STRUCT_DATA (handle); + while (n_fields) + { + switch (*fields_desc) + { +#if 0 + case 'i': + if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w')) + || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits)))) + *mem = 0; + else + { + *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct"); + inits = SCM_CDR (inits); + } + break; +#endif + + case 'u': + if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w')) + || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits)))) + *mem = 0; + else + { + *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "init_struct"); + inits = SCM_CDR (inits); + } + break; + + case 'p': + if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w')) + || (inits == SCM_EOL)) + *mem = SCM_EOL; + else + { + *mem = SCM_CAR (inits); + inits = SCM_CDR (inits); + } + + break; + +#if 0 + case 'd': + if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w')) + || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits)))) + *((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; + } + + fields_desc += 2; + n_fields--; + mem++; + } +} + + +SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p); +#ifdef __STDC__ +SCM +scm_struct_p (SCM x) +#else +SCM +scm_struct_p (x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_struct_vtable_p (SCM x) +#else +SCM +scm_struct_vtable_p (x) + SCM x; +#endif +{ + 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); +} + +SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct); +#ifdef __STDC__ +SCM +scm_make_struct (SCM vtable, SCM tail_array_size, SCM init) +#else +SCM +scm_make_struct (vtable, tail_array_size, init) + SCM vtable; + SCM tail_array_size; + SCM init; +#endif +{ + 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 = (SCM*)scm_must_malloc (sizeof (SCM) * (2 + basic_size + tail_elts), "structure"); + *data = (SCM)(2 + basic_size + tail_elts); + data[1] = struct_num++; + data += 2; + SCM_SETCDR (handle, data); + SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + 1); + 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); +#ifdef __STDC__ +SCM +scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init) +#else +SCM +scm_make_vtable_vtable (extra_fields, tail_array_size, init) + SCM extra_fields; + SCM tail_array_size; + SCM init; +#endif +{ + 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_ARG3, 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 = (SCM*)scm_must_malloc (sizeof (SCM) * (2 + basic_size + tail_elts), "structure"); + *data = (SCM)(2 + basic_size + tail_elts); + data[1] = struct_num++; + data += 2; + SCM_SETCDR (handle, data); + SCM_SETCAR (handle, ((SCM)data) + 1); + 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); +#ifdef __STDC__ +SCM +scm_struct_ref (SCM handle, SCM pos) +#else +SCM +scm_struct_ref (handle, pos) + SCM handle; + SCM pos; +#endif +{ + SCM answer; + 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 = SCM_LENGTH (layout) / 2; + + SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_ref); + + field_type = fields_desc[p * 2]; + { + unsigned char ref; + 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); + } + } + 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); +#ifdef __STDC__ +SCM +scm_struct_set_x (SCM handle, SCM pos, SCM val) +#else +SCM +scm_struct_set_x (handle, pos, val) + SCM handle; + SCM pos; + SCM val; +#endif +{ + 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 = SCM_LENGTH (layout) / 2; + + SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x); + + field_type = fields_desc[p * 2]; + { + unsigned char set_x; + set_x = fields_desc [p * 2 + 1]; + if (set_x != 'w') + SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x); + } + 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); +#ifdef __STDC__ +SCM +scm_struct_vtable (SCM handle) +#else +SCM +scm_struct_vtable (handle) + SCM handle; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_struct_vtable_tag (SCM handle) +#else +SCM +scm_struct_vtable_tag (handle) + SCM handle; +#endif +{ + 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]); +} + + + + +#ifdef __STDC__ +void +scm_init_struct (void) +#else +void +scm_init_struct () +#endif +{ + 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 new file mode 100644 index 000000000..b444e282b --- /dev/null +++ b/libguile/struct.h @@ -0,0 +1,101 @@ +/* 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 "__scm.h" + + + +/* These are how the initial words of a vtable are allocated. */ +#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]) + + + +#ifdef __STDC__ +extern SCM scm_make_struct_layout (SCM fields); +extern SCM scm_struct_p (SCM x); +extern SCM scm_struct_vtable_p (SCM x); +extern SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init); +extern SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init); +extern SCM scm_struct_ref (SCM handle, SCM pos); +extern SCM scm_struct_set_x (SCM handle, SCM pos, SCM val); +extern SCM scm_struct_vtable (SCM handle); +extern SCM scm_struct_vtable_tag (SCM handle); +extern void scm_init_struct (void); + +#else /* STDC */ +extern SCM scm_make_struct_layout (); +extern SCM scm_struct_p (); +extern SCM scm_struct_vtable_p (); +extern SCM scm_make_struct (); +extern SCM scm_make_vtable_vtable (); +extern SCM scm_struct_ref (); +extern SCM scm_struct_set_x (); +extern SCM scm_struct_vtable (); +extern SCM scm_struct_vtable_tag (); +extern void scm_init_struct (); + +#endif /* STDC */ + + + + + + + + +#endif /* STRUCTH */ diff --git a/libguile/symbols.c b/libguile/symbols.c new file mode 100644 index 000000000..4a6dd6065 --- /dev/null +++ b/libguile/symbols.c @@ -0,0 +1,781 @@ +/* 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" + + + + +/* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets. + */ +#define NUM_HASH_BUCKETS 137 + + + + +/* {Symbols} + */ + +#ifdef __STDC__ +unsigned long +scm_strhash (unsigned char *str, scm_sizet len, unsigned long n) +#else +unsigned long +scm_strhash (str, len, n) + unsigned char *str; + scm_sizet len; + unsigned long n; +#endif +{ + 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. + */ +#ifdef __STDC__ +SCM +scm_sym2vcell (SCM sym, SCM thunk, SCM definep) +#else +SCM +scm_sym2vcell (sym, thunk, definep) + SCM sym; + SCM thunk; + SCM definep; +#endif +{ + 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_CDR (lsym))) + { + z = SCM_CAR (lsym); + if (SCM_CAR (z) == sym) + { + if (definep) + { + *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 (defaulting to scm_symhash). + */ +#ifdef __STDC__ +SCM +scm_sym2ovcell_soft (SCM sym, SCM obarray) +#else +SCM +scm_sym2ovcell_soft (sym, obarray) + SCM sym; + SCM obarray; +#endif +{ + 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; +} + +#ifdef __STDC__ +SCM +scm_sym2ovcell (SCM sym, SCM obarray) +#else +SCM +scm_sym2ovcell (sym, obarray) + SCM sym; + SCM obarray; +#endif +{ + 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 */ +} + +#ifdef __STDC__ +SCM +scm_intern_obarray_soft (char *name, scm_sizet len, SCM obarray, int softness) +#else +SCM +scm_intern_obarray_soft (name, len, obarray, softness) + char *name; + scm_sizet len; + SCM obarray; + int softness; +#endif +{ + 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)); + + if (softness == -1) + goto mustintern_symbol; + + 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; + } + + mustintern_symbol: + lsym = scm_makfromstr (name, len, SCM_SYMBOL_SLOTS); + + SCM_SETLENGTH (lsym, (long) len, scm_tc7_msymbol); + SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (lsym) = SCM_BOOL_F; + SCM_SYMBOL_HASH (lsym) = scm_hash; + if (obarray == SCM_BOOL_F) + { + SCM answer; + SCM_REALLOW_INTS; + SCM_NEWCELL (answer); + SCM_DEFER_INTS; + SCM_CAR (answer) = lsym; + SCM_CDR (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); + } +} + +#ifdef __STDC__ +SCM +scm_intern_obarray (char *name, scm_sizet len, SCM obarray) +#else +SCM +scm_intern_obarray (name, len, obarray) + char *name; + scm_sizet len; + SCM obarray; +#endif +{ + return scm_intern_obarray_soft (name, len, obarray, 0); +} + + +#ifdef __STDC__ +SCM +scm_intern (char *name, scm_sizet len) +#else +SCM +scm_intern (name, len) + char *name; + scm_sizet len; +#endif +{ + return scm_intern_obarray (name, len, scm_symhash); +} + +#ifdef __STDC__ +SCM +scm_intern0 (char * name) +#else +SCM +scm_intern0 (name) + char * name; +#endif +{ + return scm_intern (name, strlen (name)); +} + + +#ifdef __STDC__ +SCM +scm_sysintern (char *name, SCM val) +#else +SCM +scm_sysintern (name, val) + char *name; + SCM val; +#endif +{ + SCM easy_answer; + SCM_DEFER_INTS; + easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1); + if (SCM_NIMP (easy_answer)) + { + SCM_CDR (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); +#ifdef __STDC__ +SCM +scm_symbol_p(SCM x) +#else +SCM +scm_symbol_p(x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_symbol_to_string(SCM s) +#else +SCM +scm_symbol_to_string(s) + SCM s; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_to_symbol(SCM s) +#else +SCM +scm_string_to_symbol(s) + SCM s; +#endif +{ + 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_SCM_STRINGP (answer) = SCM_BOOL_F; + else + SCM_SYMBOL_MULTI_BYTE_SCM_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); +#ifdef __STDC__ +SCM +scm_string_to_obarray_symbol(SCM o, SCM s, SCM softp) +#else +SCM +scm_string_to_obarray_symbol(o, s, softp) + SCM o; + SCM s; + SCM softp; +#endif +{ + 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_SCM_STRINGP (answer) = SCM_BOOL_F; + else + SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_T; + } + return answer; +} + +SCM_PROC(s_intern_symbol, "intern-symbol", 2, 0, 0, scm_intern_symbol); +#ifdef __STDC__ +SCM +scm_intern_symbol(SCM o, SCM s) +#else +SCM +scm_intern_symbol(o, s) + SCM o; + SCM s; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_unintern_symbol(SCM o, SCM s) +#else +SCM +scm_unintern_symbol(o, s) + SCM o; + SCM s; +#endif +{ + 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_CDR(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); +#ifdef __STDC__ +SCM +scm_symbol_binding (SCM o, SCM s) +#else +SCM +scm_symbol_binding (o, s) + SCM o; + SCM s; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_symbol_interned_p (SCM o, SCM s) +#else +SCM +scm_symbol_interned_p (o, s) + SCM o; + SCM s; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_symbol_bound_p (SCM o, SCM s) +#else +SCM +scm_symbol_bound_p (o, s) + SCM o; + SCM s; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_symbol_set_x (SCM o, SCM s, SCM v) +#else +SCM +scm_symbol_set_x (o, s, v) + SCM o; + SCM s; + SCM v; +#endif +{ + 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_CDR(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_SCM_STRINGP (s) = SCM_BOOL_F; + SCM_CDR (string) = SCM_EOL; + SCM_CAR (string) = SCM_EOL; +} + + +SCM_PROC(s_symbol_fref, "symbol-fref", 1, 0, 0, scm_symbol_fref); +#ifdef __STDC__ +SCM +scm_symbol_fref (SCM s) +#else +SCM +scm_symbol_fref (s) + SCM s; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_symbol_pref (SCM s) +#else +SCM +scm_symbol_pref (s) + SCM s; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_symbol_fset_x (SCM s, SCM val) +#else +SCM +scm_symbol_fset_x (s, val) + SCM s; + SCM val; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_symbol_pset_x (SCM s, SCM val) +#else +SCM +scm_symbol_pset_x (s, val) + SCM s; + SCM val; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_symbol_hash (SCM s) +#else +SCM +scm_symbol_hash (s) + SCM s; +#endif +{ + SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_hash); + return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s)); +} + + +#ifdef __STDC__ +void +scm_init_symbols (void) +#else +void +scm_init_symbols () +#endif +{ +#include "symbols.x" +} + diff --git a/libguile/symbols.h b/libguile/symbols.h new file mode 100644 index 000000000..b1486ce7a --- /dev/null +++ b/libguile/symbols.h @@ -0,0 +1,141 @@ +/* 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 "__scm.h" + + +extern int scm_symhash_dim; + +#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_CAR(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_SCM_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)) + + + +#ifdef __STDC__ +extern unsigned long scm_strhash (unsigned char *str, scm_sizet len, unsigned long n); +extern SCM scm_sym2vcell (SCM sym, SCM thunk, SCM definep); +extern SCM scm_sym2ovcell_soft (SCM sym, SCM obarray); +extern SCM scm_sym2ovcell (SCM sym, SCM obarray); +extern SCM scm_intern_obarray_soft (char *name, scm_sizet len, SCM obarray, int softness); +extern SCM scm_intern_obarray (char *name, scm_sizet len, SCM obarray); +extern SCM scm_intern (char *name, scm_sizet len); +extern SCM scm_intern0 (char * name); +extern SCM scm_sysintern (char *name, SCM val); +extern SCM scm_symbol_p(SCM x); +extern SCM scm_symbol_to_string(SCM s); +extern SCM scm_string_to_symbol(SCM s); +extern SCM scm_string_to_obarray_symbol(SCM o, SCM s, SCM softp); +extern SCM scm_intern_symbol(SCM o, SCM s); +extern SCM scm_unintern_symbol(SCM o, SCM s); +extern SCM scm_symbol_binding (SCM o, SCM s); +extern SCM scm_symbol_interned_p (SCM o, SCM s); +extern SCM scm_symbol_bound_p (SCM o, SCM s); +extern SCM scm_symbol_set_x (SCM o, SCM s, SCM v); +extern SCM scm_symbol_fref (SCM s); +extern SCM scm_symbol_pref (SCM s); +extern SCM scm_symbol_fset_x (SCM s, SCM val); +extern SCM scm_symbol_pset_x (SCM s, SCM val); +extern SCM scm_symbol_hash (SCM s); +extern void scm_init_symbols (void); + +#else /* STDC */ +extern unsigned long scm_strhash (); +extern SCM scm_sym2vcell (); +extern SCM scm_sym2ovcell_soft (); +extern SCM scm_sym2ovcell (); +extern SCM scm_intern_obarray_soft (); +extern SCM scm_intern_obarray (); +extern SCM scm_intern (); +extern SCM scm_intern0 (); +extern SCM scm_sysintern (); +extern SCM scm_symbol_p(); +extern SCM scm_symbol_to_string(); +extern SCM scm_string_to_symbol(); +extern SCM scm_string_to_obarray_symbol(); +extern SCM scm_intern_symbol(); +extern SCM scm_unintern_symbol(); +extern SCM scm_symbol_binding (); +extern SCM scm_symbol_interned_p (); +extern SCM scm_symbol_bound_p (); +extern SCM scm_symbol_set_x (); +extern SCM scm_symbol_fref (); +extern SCM scm_symbol_pref (); +extern SCM scm_symbol_fset_x (); +extern SCM scm_symbol_pset_x (); +extern SCM scm_symbol_hash (); +extern void scm_init_symbols (); + +#endif /* STDC */ + + + + + + +#endif /* SYMBOLSH */ diff --git a/libguile/tag.c b/libguile/tag.c new file mode 100644 index 000000000..a305d70b2 --- /dev/null +++ b/libguile/tag.c @@ -0,0 +1,220 @@ +/* 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" + + + +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); +#ifdef __STDC__ +SCM +scm_tag (SCM x) +#else +SCM +scm_tag (x) + SCM x; +#endif +{ + 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); +} + + + + +#ifdef __STDC__ +void +scm_init_tag (void) +#else +void +scm_init_tag () +#endif +{ +#include "tag.x" +} + diff --git a/libguile/tag.h b/libguile/tag.h new file mode 100644 index 000000000..a7d1ab761 --- /dev/null +++ b/libguile/tag.h @@ -0,0 +1,63 @@ +/* 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 "__scm.h" + + + + + + +#ifdef __STDC__ +extern SCM scm_tag (SCM x); +extern void scm_init_tag (void); + +#else /* STDC */ +extern SCM scm_tag (); +extern void scm_init_tag (); + +#endif /* STDC */ +#endif /* TAGH */ diff --git a/libguile/tags.h b/libguile/tags.h new file mode 100644 index 000000000..1469a90f6 --- /dev/null +++ b/libguile/tags.h @@ -0,0 +1,532 @@ +/* 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 chaning 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. + * + * 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. + * + * 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: + * D S + * scm_tc7_string = Gxxx0101 + * scm_tc7_mb_string = Gxxx0111 + * scm_tc7_substring = Gxxx1101 + * scm_tc7_mb_substring = Gxxx1111 + * + * 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. + * + * TYP7DS turns all string tags 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_CDR(x) |= 1) +#define SCM_CLRGCMARK(x) (SCM_CDR(x) &= ~1L) +#define SCM_SETGC8MARK(x) (SCM_CAR(x) |= 0x80) +#define SCM_CLRGC8MARK(x) (SCM_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_ISYMSCM_CHARS(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_UNUSED_NIL_VALUE 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 + + +#ifdef __STDC__ + +#else /* STDC */ + +#endif /* STDC */ + + +#endif /* TAGSH */ diff --git a/libguile/throw.c b/libguile/throw.c new file mode 100644 index 000000000..a84d7e92e --- /dev/null +++ b/libguile/throw.c @@ -0,0 +1,291 @@ +/* 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" + + + + +/* {Catch and Throw} + */ +static int scm_tc16_jmpbuffer; + +SCM scm_bad_throw_vcell; + +#define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer) +#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L)) +#define ACTIVATEJB(O) (SCM_CAR (O) |= (1L << 16L)) +#define DEACTIVATEJB(O) (SCM_CAR (O) &= ~(1L << 16L)) + +#ifdef DEBUG_EXTENSIONS +#define JBSCM_DFRAME(O) ((debug_frame*)SCM_CAR (SCM_CDR (O)) ) +#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) ) +#define SETJBSCM_DFRAME(O,X) SCM_CAR(SCM_CDR (O)) = (SCM)(X) +#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X) +#else +#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) ) +#define SETJBJMPBUF SCM_SETCDR +#endif + +#ifdef __STDC__ +static int +printjb (SCM exp, SCM port, int writing) +#else +static int +printjb (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + 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 ; +} + +/* !!! The mark function needs to be different for + * debugging support. A. Green + */ +static scm_smobfuns jbsmob = {scm_mark0, scm_free0, printjb, 0}; + +#ifdef __STDC__ +static SCM +make_jmpbuf (void) +#else +static SCM +make_jmpbuf () +#endif +{ + SCM answer; + SCM_NEWCELL (answer); +#ifdef DEBUG_EXTENSIONS + SCM_NEWCELL (SCM_CDR (answer)); +#endif + SCM_DEFER_INTS; + { + SCM_CAR(answer) = scm_tc16_jmpbuffer; + SETJBJMPBUF(answer, (jmp_buf *)0); + DEACTIVATEJB(answer); + } + SCM_ALLOW_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_PROC(s_catch, "catch", 3, 0, 0, scm_catch); +#ifdef __STDC__ +SCM +scm_catch (SCM tag, SCM thunk, SCM handler) +#else +SCM +scm_catch (tag, thunk, handler) + SCM tag; + SCM thunk; + SCM handler; +#endif +{ + struct jmp_buf_and_retval jbr; + SCM jmpbuf; + SCM answer; + + SCM_ASSERT ((tag == SCM_BOOL_F) || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || (tag == SCM_BOOL_T), + tag, SCM_ARG1, s_catch); + jmpbuf = make_jmpbuf (); + answer = SCM_EOL; + scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds); + SETJBJMPBUF(jmpbuf, &jbr.buf); +#ifdef DEBUG_EXTENSIONS + SETJBSCM_DFRAME(jmpbuf, last_debug_info_frame); +#endif + if (setjmp (jbr.buf)) + { + SCM throw_tag; + SCM throw_args; + + SCM_DEFER_INTS; + DEACTIVATEJB (jmpbuf); + scm_dynwinds = SCM_CDR (scm_dynwinds); + SCM_ALLOW_INTS; + throw_args = jbr.retval; + throw_tag = jbr.throw_tag; + jbr.throw_tag = SCM_EOL; + jbr.retval = SCM_EOL; + answer = scm_apply (handler, scm_cons (throw_tag, throw_args), SCM_EOL); + } + else + { + ACTIVATEJB (jmpbuf); + answer = scm_apply (thunk, + ((tag == SCM_BOOL_F) ? scm_cons (jmpbuf, SCM_EOL) : SCM_EOL), + SCM_EOL); + SCM_DEFER_INTS; + DEACTIVATEJB (jmpbuf); + scm_dynwinds = SCM_CDR (scm_dynwinds); + SCM_ALLOW_INTS; + } + return answer; +} + + +static char s_throw[]; +#ifdef __STDC__ +SCM +scm_ithrow (SCM key, SCM args, int noreturn) +#else +SCM +scm_ithrow (key, args, noreturn) + SCM key; + SCM args; + int noreturn; +#endif +{ + 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 hook; + + 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; + + dynpair = scm_sloppy_assq (key, scm_dynwinds); + + if (dynpair == SCM_BOOL_F) + dynpair = scm_sloppy_assq (SCM_BOOL_T, scm_dynwinds); + + hook = SCM_CDR (scm_bad_throw_vcell); + if ((dynpair == SCM_BOOL_F) + && (SCM_BOOL_T == scm_procedure_p (hook))) + { + SCM answer; + answer = scm_apply (hook, scm_cons (key, args), SCM_EOL); + } + + 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)); + longjmp (SCM_JMPBUF (scm_rootcont), 1); + } + } + } +#ifdef DEBUG_EXTENSIONS + last_debug_info_frame = JBSCM_DFRAME (jmpbuf); +#endif + for (wind_goal = scm_dynwinds; + SCM_CDAR (wind_goal) != jmpbuf; + wind_goal = SCM_CDR (wind_goal)) + ; + { + struct jmp_buf_and_retval * jbr; + jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf); + jbr->throw_tag = key; + jbr->retval = args; + } + scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal)); + longjmp (*JBJMPBUF (jmpbuf), 1); +} + + +SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw); +#ifdef __STDC__ +SCM +scm_throw (SCM key, SCM args) +#else +SCM +scm_throw (key, args) + SCM key; + SCM args; +#endif +{ + scm_ithrow (key, args, 1); + return SCM_BOOL_F; /* never really returns */ +} + + +#ifdef __STDC__ +void +scm_init_throw (void) +#else +void +scm_init_throw () +#endif +{ + scm_tc16_jmpbuffer = scm_newsmob (&jbsmob); + scm_bad_throw_vcell = scm_sysintern ("%%bad-throw", SCM_BOOL_F); +#include "throw.x" +} + diff --git a/libguile/throw.h b/libguile/throw.h new file mode 100644 index 000000000..f6aca5b24 --- /dev/null +++ b/libguile/throw.h @@ -0,0 +1,67 @@ +/* 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 "__scm.h" + + + + +#ifdef __STDC__ +extern SCM scm_catch (SCM tag, SCM thunk, SCM handler); +extern SCM scm_ithrow (SCM key, SCM args, int noreturn); +extern SCM scm_throw (SCM key, SCM args); +extern void scm_init_throw (void); + +#else /* STDC */ +extern SCM scm_catch (); +extern SCM scm_ithrow (); +extern SCM scm_throw (); +extern void scm_init_throw (); + +#endif /* STDC */ + + +#endif /* THROWH */ diff --git a/libguile/unif.c b/libguile/unif.c new file mode 100644 index 000000000..ed0e17c5c --- /dev/null +++ b/libguile/unif.c @@ -0,0 +1,2687 @@ +/* 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" + + +/* 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!"; + +#ifdef __STDC__ +SCM +scm_vector_set_length_x (SCM vect, SCM len) +#else +SCM +scm_vector_set_length_x (vect, len) + SCM vect; + SCM len; +#endif +{ + 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 + +#ifdef __STDC__ +SCM +scm_makflo (float x) +#else +SCM +scm_makflo (x) + float x; +#endif +{ + SCM z; + if (x == 0.0) + return scm_flo0; + SCM_NEWCELL (z); + SCM_DEFER_INTS; + SCM_CAR (z) = scm_tc_flo; + SCM_FLO (z) = x; + SCM_ALLOW_INTS; + return z; +} +#endif +#endif + +#ifdef __STDC__ +SCM +scm_make_uve (long k, SCM prot) +#else +SCM +scm_make_uve (k, prot) + long k; + SCM prot; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_uniform_vector_length (SCM v) +#else +SCM +scm_uniform_vector_length (v) + SCM v; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_array_p (SCM v, SCM prot) +#else +SCM +scm_array_p (v, prot) + SCM v; + SCM prot; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_array_rank (SCM ra) +#else +SCM +scm_array_rank (ra) + SCM ra; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_array_dimensions (SCM ra) +#else +SCM +scm_array_dimensions (ra) + SCM ra; +#endif +{ + 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"; + +#ifdef __STDC__ +long +scm_aind (SCM ra, SCM args, char *what) +#else +long +scm_aind (ra, args, what) + SCM ra, + SCM args; + char *what; +#endif +{ + 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_UNDEFINED, SCM_WNA, what); + 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_UNDEFINED, SCM_WNA, what); + return pos; +} + + +#ifdef __STDC__ +SCM +scm_make_ra (int ndim) +#else +SCM +scm_make_ra (ndim) + int ndim; +#endif +{ + 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_CAR (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. */ + +#ifdef __STDC__ +SCM +scm_shap2ra (SCM args, char *what) +#else +SCM +scm_shap2ra (args, what) + SCM args; + char *what; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill) +#else +SCM +scm_dimensions_to_uniform_array (dims, prot, fill) + SCM dims; + SCM prot; + SCM fill; +#endif +{ + 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), fill, SCM_WNA, s_dimensions_to_uniform_array); + 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_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), fill, SCM_WNA, s_dimensions_to_uniform_array); + 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; +} + +#ifdef __STDC__ +void +scm_ra_set_contp (SCM ra) +#else +void +scm_ra_set_contp (ra) + SCM ra; +#endif +{ + scm_sizet k = SCM_ARRAY_NDIM (ra); + long inc; + if (k) + inc = SCM_ARRAY_DIMS (ra)[k - 1].inc; + while (k--) + { + if (inc != SCM_ARRAY_DIMS (ra)[k].inc) + { + SCM_CAR (ra) &= ~SCM_ARRAY_CONTIGUOUS; + return; + } + inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1); + } + SCM_CAR (ra) |= SCM_ARRAY_CONTIGUOUS; +} + + +SCM_PROC(s_make_shared_array, "make-shared-array", 2, 0, 1, scm_make_shared_array); +#ifdef __STDC__ +SCM +scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims) +#else +SCM +scm_make_shared_array (oldra, mapfunc, dims) + SCM oldra; + SCM mapfunc; + SCM dims; +#endif +{ + 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_CAR (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); +#ifdef __STDC__ +SCM +scm_transpose_array (SCM args) +#else +SCM +scm_transpose_array (args) + SCM args; +#endif +{ + SCM ra, res, vargs, *ve = &vargs; + scm_array_dim *s, *r; + int ndim, i, k; + SCM_ASSERT (SCM_NIMP (args), SCM_UNDEFINED, SCM_WNA, s_transpose_array); + ra = SCM_CAR (args); + args = SCM_CDR (args); + switch SCM_TYP7 + (ra) + { + default: + badarg:scm_wta (ra, (char *) SCM_ARG1, 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_UNDEFINED, SCM_WNA, s_transpose_array); + SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_ARG1, 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_UNDEFINED, SCM_WNA, s_transpose_array); + 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); +#ifdef __STDC__ +SCM +scm_enclose_array (SCM axes) +#else +SCM +scm_enclose_array (axes) + SCM axes; +#endif +{ + SCM axv, ra, res, ra_inr; + scm_array_dim vdim, *s = &vdim; + int ndim, j, k, ninr, noutr; + SCM_ASSERT (SCM_NIMP (axes), SCM_UNDEFINED, SCM_WNA, s_enclose_array); + 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_UNDEFINED, SCM_WNA, s_enclose_array); + 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); +#ifdef __STDC__ +SCM +scm_array_in_bounds_p (SCM args) +#else +SCM +scm_array_in_bounds_p (args) + SCM args; +#endif +{ + SCM v, ind = SCM_EOL; + long pos = 0; + register scm_sizet k; + register long j; + scm_array_dim *s; + SCM_ASSERT (SCM_NIMP (args), args, SCM_WNA, s_array_in_bounds_p); + 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_wta (args, (char *) SCM_WNA, 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); +#ifdef __STDC__ +SCM +scm_uniform_vector_ref (SCM v, SCM args) +#else +SCM +scm_uniform_vector_ref (v, args) + SCM v; + SCM args; +#endif +{ + 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); + outrng:scm_wta (SCM_MAKINUM (pos), (char *) SCM_OUTOFRANGE, s_uniform_vector_ref); + wna:scm_wta (SCM_UNDEFINED, (char *) SCM_WNA, 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.) */ +#ifdef __STDC__ +SCM +scm_cvref (SCM v, scm_sizet pos, SCM last) +#else +SCM +scm_cvref (v, pos, last) + SCM v; + scm_sizet pos; + SCM last; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_array_set_x (SCM v, SCM obj, SCM args) +#else +SCM +scm_array_set_x (v, obj, args) + SCM v; + SCM obj; + SCM args; +#endif +{ + 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); + outrng:scm_wta (SCM_MAKINUM (pos), (char *) SCM_OUTOFRANGE, s_array_set_x); + wna:scm_wta (SCM_UNDEFINED, (char *) SCM_WNA, 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); +#ifdef __STDC__ +SCM +scm_array_contents (SCM ra, SCM strict) +#else +SCM +scm_array_contents (ra, strict) + SCM ra; + SCM strict; +#endif +{ + 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; + } + } +} + +#ifdef __STDC__ +SCM +scm_ra2contig (SCM ra, int copy) +#else +SCM +scm_ra2contig (ra, copy) + SCM ra; + int copy; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_uniform_array_read_x (SCM ra, SCM port) +#else +SCM +scm_uniform_array_read_x (ra, port) + SCM ra; + SCM port; +#endif +{ + SCM cra, 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); +#ifdef __STDC__ +SCM +scm_uniform_array_write (SCM v, SCM port) +#else +SCM +scm_uniform_array_write (v, port) + SCM v; + SCM port; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_bit_count (SCM item, SCM seq) +#else +SCM +scm_bit_count (item, seq) + SCM item; + SCM seq; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_bit_position (SCM item, SCM v, SCM k) +#else +SCM +scm_bit_position (item, v, k) + SCM item; + SCM v; + SCM k; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_bit_set_star_x (SCM v, SCM kv, SCM obj) +#else +SCM +scm_bit_set_star_x (v, kv, obj) + SCM v; + SCM kv; + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_bit_count_star (SCM v, SCM kv, SCM obj) +#else +SCM +scm_bit_count_star (v, kv, obj) + SCM v; + SCM kv; + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_bit_invert_x (SCM v) +#else +SCM +scm_bit_invert_x (v) + SCM v; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_upcase_x (SCM v) +#else +SCM +scm_string_upcase_x (v) + SCM v; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_string_downcase_x (SCM v) +#else +SCM +scm_string_downcase_x (v) + SCM v; +#endif +{ + 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; +} + + +#ifdef __STDC__ +SCM +scm_istr2bve (char *str, long len) +#else +SCM +scm_istr2bve (str, len) + char *str; + long len; +#endif +{ + 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; +} + + +#ifdef __STDC__ +static SCM +ra2l (SCM ra, scm_sizet base, scm_sizet k) +#else +static SCM +ra2l (ra, base, k) + SCM ra; + scm_sizet base; + scm_sizet k; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_array_to_list (SCM v) +#else +SCM +scm_array_to_list (v) + SCM v; +#endif +{ + 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_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array); +#ifdef __STDC__ +SCM +scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst) +#else +SCM +scm_list_to_uniform_array (ndim, prot, lst) + SCM ndim; + SCM prot; + SCM lst; +#endif +{ + 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; +} + + +#ifdef __STDC__ +static int +l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k) +#else +static int +l2ra (lst, ra, base, k) + SCM lst; + SCM ra; + scm_sizet base; + scm_sizet k; +#endif +{ + 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; +} + +#ifdef __STDC__ +static void +rapr1 (SCM ra, scm_sizet j, scm_sizet k, SCM port, int writing) +#else +static void +rapr1 (ra, j, k, port, writing) + SCM ra; + scm_sizet j; + scm_sizet k; + SCM port; + int writing; +#endif +{ + 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, writing); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + SCM_ARRAY_BASE (ra) = j; + scm_iprin1 (ra, port, writing); + } + 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, writing); + 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, writing); + 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, writing); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, writing); + } + break; + case scm_tc7_string: + if (n-- > 0) + scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing); + if (writing) + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing); + } + 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, writing); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; + scm_floprint (z, port, writing); + } + } + 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, writing); + for (j += inc; n-- > 0; j += inc) + { + scm_gen_putc (' ', port); + SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; + scm_floprint (z, port, writing); + } + } + 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, writing); + 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, writing); + } + } + break; +#endif /*SCM_FLOATS*/ + } +} + + +#ifdef __STDC__ +int +scm_raprin1 (SCM exp, SCM port, int writing) +#else +int +scm_raprin1 (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + 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, writing); + 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, writing); + scm_gen_putc (')', port); + return 1; +} + +SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype); +#ifdef __STDC__ +SCM +scm_array_prototype (SCM ra) +#else +SCM +scm_array_prototype (ra) + SCM ra; +#endif +{ + 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 + } +} + +#ifdef __STDC__ +static SCM +markra (SCM ptr) +#else +static SCM +markra (ptr) + SCM ptr; +#endif +{ + if SCM_GC8MARKP + (ptr) return SCM_BOOL_F; + SCM_SETGC8MARK (ptr); + return SCM_ARRAY_V (ptr); +} + +#ifdef __STDC__ +static scm_sizet +freera (SCM ptr) +#else +static scm_sizet +freera (ptr) + SCM ptr; +#endif +{ + 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() */ +#ifdef __STDC__ +void +scm_init_unif (void) +#else +void +scm_init_unif () +#endif +{ +#include "unif.x" + scm_tc16_array = scm_newsmob (&rasmob); + scm_add_feature ("array"); +} + +#else /* ARRAYS */ + +#ifdef __STDC__ +int +scm_raprin1 (SCM exp, SCM port, int writing) +#else +int +scm_raprin1 (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + return 0; +} + +#ifdef __STDC__ +SCM +scm_istr2bve (char *str, long len) +#else +SCM +scm_istr2bve (str, len) + char *str; + long len; +#endif +{ + return SCM_BOOL_F; +} + +#ifdef __STDC__ +SCM +scm_array_equal_p (SCM ra0, SCM ra1) +#else +SCM +scm_array_equal_p (ra0, ra1) + SCM ra0; + SCM ra1; +#endif +{ + 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 new file mode 100644 index 000000000..077621c6f --- /dev/null +++ b/libguile/unif.h @@ -0,0 +1,164 @@ +/* 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 "__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)) + + +#ifdef __STDC__ +extern SCM scm_vector_set_length_x (SCM vect, SCM len); +extern SCM scm_makflo (float x); +extern SCM scm_make_uve (long k, SCM prot); +extern SCM scm_uniform_vector_length (SCM v); +extern SCM scm_array_p (SCM v, SCM prot); +extern SCM scm_array_rank (SCM ra); +extern SCM scm_array_dimensions (SCM ra); +extern long scm_aind (SCM ra, SCM args, char *what); +extern SCM scm_make_ra (int ndim); +extern SCM scm_shap2ra (SCM args, char *what); +extern SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill); +extern void scm_ra_set_contp (SCM ra); +extern SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims); +extern SCM scm_transpose_array (SCM args); +extern SCM scm_enclose_array (SCM axes); +extern SCM scm_array_in_bounds_p (SCM args); +extern SCM scm_uniform_vector_ref (SCM v, SCM args); +extern SCM scm_cvref (SCM v, scm_sizet pos, SCM last); +extern SCM scm_array_set_x (SCM v, SCM obj, SCM args); +extern SCM scm_array_contents (SCM ra, SCM strict); +extern SCM scm_ra2contig (SCM ra, int copy); +extern SCM scm_uniform_array_read_x (SCM ra, SCM port); +extern SCM scm_uniform_array_write (SCM v, SCM port); +extern SCM scm_bit_count (SCM item, SCM seq); +extern SCM scm_bit_position (SCM item, SCM v, SCM k); +extern SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj); +extern SCM scm_bit_count_star (SCM v, SCM kv, SCM obj); +extern SCM scm_bit_invert_x (SCM v); +extern SCM scm_string_upcase_x (SCM v); +extern SCM scm_string_downcase_x (SCM v); +extern SCM scm_istr2bve (char *str, long len); +extern SCM scm_array_to_list (SCM v); +extern SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst); +extern int scm_raprin1 (SCM exp, SCM port, int writing); +extern SCM scm_array_prototype (SCM ra); +extern void scm_init_unif (void); +extern int scm_raprin1 (SCM exp, SCM port, int writing); +extern SCM scm_istr2bve (char *str, long len); +extern SCM scm_array_equal_p (SCM ra0, SCM ra1); + +#else /* STDC */ +extern SCM scm_vector_set_length_x (); +extern SCM scm_makflo (); +extern SCM scm_make_uve (); +extern SCM scm_uniform_vector_length (); +extern SCM scm_array_p (); +extern SCM scm_array_rank (); +extern SCM scm_array_dimensions (); +extern long scm_aind (); +extern SCM scm_make_ra (); +extern SCM scm_shap2ra (); +extern SCM scm_dimensions_to_uniform_array (); +extern void scm_ra_set_contp (); +extern SCM scm_make_shared_array (); +extern SCM scm_transpose_array (); +extern SCM scm_enclose_array (); +extern SCM scm_array_in_bounds_p (); +extern SCM scm_uniform_vector_ref (); +extern SCM scm_cvref (); +extern SCM scm_array_set_x (); +extern SCM scm_array_contents (); +extern SCM scm_ra2contig (); +extern SCM scm_uniform_array_read_x (); +extern SCM scm_uniform_array_write (); +extern SCM scm_bit_count (); +extern SCM scm_bit_position (); +extern SCM scm_bit_set_star_x (); +extern SCM scm_bit_count_star (); +extern SCM scm_bit_invert_x (); +extern SCM scm_string_upcase_x (); +extern SCM scm_string_downcase_x (); +extern SCM scm_istr2bve (); +extern SCM scm_array_to_list (); +extern SCM scm_list_to_uniform_array (); +extern int scm_raprin1 (); +extern SCM scm_array_prototype (); +extern void scm_init_unif (); +extern int scm_raprin1 (); +extern SCM scm_istr2bve (); +extern SCM scm_array_equal_p (); + +#endif /* STDC */ + + + + + +#endif /* UNIFH */ diff --git a/libguile/variable.c b/libguile/variable.c new file mode 100644 index 000000000..984de26db --- /dev/null +++ b/libguile/variable.c @@ -0,0 +1,282 @@ +/* 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" + + +#ifdef __STDC__ +static scm_sizet +free_var (SCM obj) +#else +static scm_sizet +free_var (obj) + SCM obj; +#endif +{ + return 0; +} + + +#ifdef __STDC__ +static int +prin_var (SCM exp, SCM port, int writing) +#else +static int +prin_var (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + 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, writing); + } + scm_gen_puts (scm_regular_string, " binding: ", port); + scm_iprin1 (SCM_CDR (val_cell), port, writing); + } + scm_gen_putc('>', port); + return 1; +} + +#ifdef __STDC__ +static SCM +scm_markvar (SCM ptr) +#else +static SCM +scm_markvar (ptr) + SCM ptr; +#endif +{ + 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 variable_sym; + +#ifdef __STDC__ +static SCM +make_vcell_variable (SCM vcell) +#else +static SCM +make_vcell_variable (vcell) + SCM vcell; +#endif +{ + SCM answer; + SCM_NEWCELL(answer); + SCM_REDEFER_INTS; + SCM_CAR(answer) = scm_tc16_variable; + SCM_CDR(answer) = vcell; + SCM_REALLOW_INTS; + return answer; +} + +SCM_PROC(s_make_variable, "make-variable", 2, 0, 0, scm_make_variable); +#ifdef __STDC__ +SCM +scm_make_variable (SCM init, SCM name_hint) +#else +SCM +scm_make_variable (init, name_hint) + SCM init; + SCM name_hint; +#endif +{ + SCM val_cell; + SCM_NEWCELL(val_cell); + SCM_DEFER_INTS; + SCM_CAR(val_cell) = name_hint; + SCM_CDR(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); +#ifdef __STDC__ +SCM +scm_make_undefined_variable (SCM name_hint) +#else +SCM +scm_make_undefined_variable (name_hint) + SCM name_hint; +#endif +{ + SCM vcell; + + if (name_hint == SCM_UNDEFINED) + name_hint = variable_sym; + + SCM_NEWCELL (vcell); + SCM_DEFER_INTS; + SCM_CAR (vcell) = name_hint; + SCM_CDR (vcell) = SCM_UNDEFINED; + SCM_ALLOW_INTS; + return make_vcell_variable (vcell); +} + + +SCM_PROC(s_variable_p, "variable?", 1, 0, 0, scm_variable_p); +#ifdef __STDC__ +SCM +scm_variable_p (SCM obj) +#else +SCM +scm_variable_p (obj) + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_variable_ref (SCM var) +#else +SCM +scm_variable_ref (var) + SCM var; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_variable_set_x (SCM var, SCM val) +#else +SCM +scm_variable_set_x (var, val) + SCM var; + SCM val; +#endif +{ + SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_set_x); + SCM_CDR (SCM_CDR (var)) = val; + return SCM_UNSPECIFIED; +} + + +SCM_PROC(s_builtin_variable, "builtin-variable", 1, 0, 0, scm_builtin_variable); +#ifdef __STDC__ +SCM +scm_builtin_variable (SCM name) +#else +SCM +scm_builtin_variable (name) + SCM name; +#endif +{ + 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_CDR (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); +#ifdef __STDC__ +SCM +scm_variable_bound_p (SCM var) +#else +SCM +scm_variable_bound_p (var) + SCM var; +#endif +{ + 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); +} + + + +#ifdef __STDC__ +void +scm_init_variable (void) +#else +void +scm_init_variable () +#endif +{ + scm_tc16_variable = scm_newsmob (&variable_smob); + variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED)); +#include "variable.x" +} + diff --git a/libguile/variable.h b/libguile/variable.h new file mode 100644 index 000000000..b9d84fd8c --- /dev/null +++ b/libguile/variable.h @@ -0,0 +1,87 @@ +/* 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 "__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_UDSCM_VARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) +#define SCM_DEFSCM_VARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) + + +#ifdef __STDC__ +extern SCM scm_make_variable (SCM init, SCM name_hint); +extern SCM scm_make_udvariable (SCM name_hint); +extern SCM scm_variable_p (SCM obj); +extern SCM scm_variable_ref (SCM var); +extern SCM scm_variable_set_x (SCM var, SCM val); +extern SCM scm_builtin_variable (SCM name); +extern SCM scm_variable_bound_p (SCM var); +extern void scm_init_variable (void); + +#else /* STDC */ +extern SCM scm_make_variable (); +extern SCM scm_make_udvariable (); +extern SCM scm_variable_p (); +extern SCM scm_variable_ref (); +extern SCM scm_variable_set_x (); +extern SCM scm_builtin_variable (); +extern SCM scm_variable_bound_p (); +extern void scm_init_variable (); + +#endif /* STDC */ + + + + + +#endif /* VARIABLEH */ diff --git a/libguile/vectors.c b/libguile/vectors.c new file mode 100644 index 000000000..c30a8590a --- /dev/null +++ b/libguile/vectors.c @@ -0,0 +1,317 @@ +/* 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" + + + + +SCM_PROC(s_vector_p, "vector?", 1, 0, 0, scm_vector_p); +#ifdef __STDC__ +SCM +scm_vector_p(SCM x) +#else +SCM +scm_vector_p(x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_vector_length(SCM v) +#else +SCM +scm_vector_length(v) + SCM v; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_vector(SCM l) +#else +SCM +scm_vector(l) + SCM l; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_vector_ref(SCM v, SCM k) +#else +SCM +scm_vector_ref(v, k) + SCM v; + SCM k; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_vector_set_x(SCM v, SCM k, SCM obj) +#else +SCM +scm_vector_set_x(v, k, obj) + SCM v; + SCM k; + SCM obj; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_make_vector(SCM k, SCM fill, SCM multip) +#else +SCM +scm_make_vector(k, fill, multip) + SCM k; + SCM fill; + SCM multip; +#endif +{ + 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_EOL; + 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); +#ifdef __STDC__ +SCM +scm_vector_to_list(SCM v) +#else +SCM +scm_vector_to_list(v) + SCM v; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_vector_fill_x(SCM v, SCM fill_x) +#else +SCM +scm_vector_fill_x(v, fill_x) + SCM v; + SCM fill_x; +#endif +{ + 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; +} + + +#ifdef __STDC__ +SCM +scm_vector_equal_p(SCM x, SCM y) +#else +SCM +scm_vector_equal_p(x, y) + SCM x; + SCM y; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_vector_move_left_x (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2) +#else +SCM +scm_vector_move_left_x (vec1, start1, end1, vec2, start2) + SCM vec1; + SCM start1; + SCM end1; + SCM vec2; + SCM start2; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_vector_move_right_x (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2) +#else +SCM +scm_vector_move_right_x (vec1, start1, end1, vec2, start2) + SCM vec1; + SCM start1; + SCM end1; + SCM vec2; + SCM start2; +#endif +{ + 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; +} + + +#ifdef __STDC__ +void +scm_init_vectors (void) +#else +void +scm_init_vectors () +#endif +{ +#include "vectors.x" +} + diff --git a/libguile/vectors.h b/libguile/vectors.h new file mode 100644 index 000000000..3cf5c6478 --- /dev/null +++ b/libguile/vectors.h @@ -0,0 +1,82 @@ +/* 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 "__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 + + +#ifdef __STDC__ +extern SCM scm_vector_p(SCM x); +extern SCM scm_vector_length(SCM v); +extern SCM scm_vector(SCM l); +extern SCM scm_vector_ref(SCM v, SCM k); +extern SCM scm_vector_set_x(SCM v, SCM k, SCM obj); +extern SCM scm_make_vector(SCM k, SCM fill, SCM multi); +extern SCM scm_vector_to_list(SCM v); +extern SCM scm_vector_fill_x(SCM v, SCM fill_x); +extern SCM scm_vector_equal_p(SCM x, SCM y); +extern void scm_init_vectors (void); + +#else /* STDC */ +extern SCM scm_vector_p(); +extern SCM scm_vector_length(); +extern SCM scm_vector(); +extern SCM scm_vector_ref(); +extern SCM scm_vector_set_x(); +extern SCM scm_make_vector(); +extern SCM scm_vector_to_list(); +extern SCM scm_vector_fill_x(); +extern SCM scm_vector_equal_p(); +extern void scm_init_vectors (); + +#endif /* STDC */ +#endif /* VECTORSH */ diff --git a/libguile/vports.c b/libguile/vports.c new file mode 100644 index 000000000..dbb67cbfe --- /dev/null +++ b/libguile/vports.c @@ -0,0 +1,241 @@ +/* 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" + + + +/* {Ports - soft ports} + * + */ + + +#ifdef __STDC__ +static int +prinsfpt (SCM exp, SCM port, int writing) +#else +static int +prinsfpt (exp, port, writing) + SCM exp; + SCM port; + int writing; +#endif +{ + 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. + */ + +#ifdef __STDC__ +static int +sfputc (int c, SCM p) +#else +static int +sfputc (c, p) + int c; + SCM p; +#endif +{ + scm_apply (SCM_VELTS (p)[0], SCM_MAKICHR (c), scm_listofnull); + errno = 0; + return c; +} + +#ifdef __STDC__ +static scm_sizet +sfwrite (char *str, scm_sizet siz, scm_sizet num, SCM p) +#else +static scm_sizet +sfwrite (str, siz, num, p) + char *str; + scm_sizet siz; + scm_sizet num; + SCM p; +#endif +{ + SCM sstr; + sstr = scm_makfromstr (str, siz * num, 0); + scm_apply (SCM_VELTS (p)[1], sstr, scm_listofnull); + errno = 0; + return num; +} + +#ifdef __STDC__ +static int +sfputs (char *s, SCM p) +#else +static int +sfputs (s, p) + char *s; + SCM p; +#endif +{ + sfwrite (s, 1, strlen (s), p); + return 0; +} + +#ifdef __STDC__ +static int +sfflush (SCM stream) +#else +static int +sfflush (stream) + SCM stream; +#endif +{ + 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; +} + +#ifdef __STDC__ +static int +sfgetc (SCM p) +#else +static int +sfgetc (p) + SCM p; +#endif +{ + 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); +} + +#ifdef __STDC__ +static int +sfclose (SCM p) +#else +static int +sfclose (p) + SCM p; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_make_soft_port (SCM pv, SCM modes) +#else +SCM +scm_make_soft_port (pv, modes) + SCM pv; + SCM modes; +#endif +{ + 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_CAR (z) = scm_tc16_sfport | scm_mode_bits (SCM_CHARS (modes)); + SCM_SETPTAB_ENTRY (z, pt); + SCM_SETSTREAM (z, pv); + SCM_ALLOW_INTS; + return z; +} + +#ifdef __STDC__ +static int +noop0 (FILE *stream) +#else +static int +noop0 (stream) + FILE *stream; +#endif +{ + return 0; +} + + +scm_ptobfuns scm_sfptob = +{ + scm_markstream, + noop0, + prinsfpt, + 0, + sfputc, + sfputs, + sfwrite, + sfflush, + sfgetc, + sfclose +}; + + +#ifdef __STDC__ +void +scm_init_vports (void) +#else +void +scm_init_vports () +#endif +{ +#include "vports.x" +} + diff --git a/libguile/vports.h b/libguile/vports.h new file mode 100644 index 000000000..17a50fa57 --- /dev/null +++ b/libguile/vports.h @@ -0,0 +1,70 @@ +/* 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 "__scm.h" + +extern scm_ptobfuns scm_sfptob; + + + + + +#ifdef __STDC__ +extern SCM scm_make_soft_port (SCM pv, SCM modes); +extern void scm_init_vports (void); + +#else /* STDC */ +extern SCM scm_make_soft_port (); +extern void scm_init_vports (); + +#endif /* STDC */ + + + + + + +#endif /* VPORTSH */ diff --git a/libguile/weaks.c b/libguile/weaks.c new file mode 100644 index 000000000..8479d76f5 --- /dev/null +++ b/libguile/weaks.c @@ -0,0 +1,242 @@ +/* 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" + + + + +/* {Weak Vectors} + */ + + +SCM_PROC(s_make_weak_vector, "make-weak-vector", 1, 1, 0, scm_make_weak_vector); +#ifdef __STDC__ +SCM +scm_make_weak_vector (SCM k, SCM fill) +#else +SCM +scm_make_weak_vector (k, fill) + SCM k; + SCM fill; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_weak_vector (SCM l) +#else +SCM +scm_weak_vector (l) + SCM l; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_weak_vector_p (SCM x) +#else +SCM +scm_weak_vector_p (x) + SCM x; +#endif +{ + return ((SCM_NIMP (x) && SCM_WVECTP (x) && !SCM_IS_WHVEC (x)) + ? SCM_BOOL_T + : SCM_BOOL_F); +} + + + + + + + +SCM_PROC(s_make_weak_hash_table, "make-weak-hash-table", 1, 0, 0, scm_make_weak_hash_table); +#ifdef __STDC__ +SCM +scm_make_weak_hash_table (SCM k) +#else +SCM +scm_make_weak_hash_table (k) + SCM k; +#endif +{ + SCM v; + SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_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); +#ifdef __STDC__ +SCM +scm_make_weak_value_hash_table (SCM k) +#else +SCM +scm_make_weak_value_hash_table (k) + SCM k; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_make_doubly_weak_hash_table (SCM k) +#else +SCM +scm_make_doubly_weak_hash_table (k) + SCM k; +#endif +{ + 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] = 3; + SCM_ALLOW_INTS; + return v; +} + +SCM_PROC(s_weak_hash_table_p, "weak-hash-table?", 1, 0, 0, scm_weak_hash_table_p); +#ifdef __STDC__ +SCM +scm_weak_hash_table_p (SCM x) +#else +SCM +scm_weak_hash_table_p (x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_weak_value_hash_table_p (SCM x) +#else +SCM +scm_weak_value_hash_table_p (x) + SCM x; +#endif +{ + 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); +#ifdef __STDC__ +SCM +scm_doubly_weak_hash_table_p (SCM x) +#else +SCM +scm_doubly_weak_hash_table_p (x) + SCM x; +#endif +{ + return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_B (x)) + ? SCM_BOOL_T + : SCM_BOOL_F); +} + + + + +#ifdef __STDC__ +void +scm_init_weaks (void) +#else +void +scm_init_weaks () +#endif +{ +#include "weaks.x" +} + diff --git a/libguile/weaks.h b/libguile/weaks.h new file mode 100644 index 000000000..98e1cb698 --- /dev/null +++ b/libguile/weaks.h @@ -0,0 +1,86 @@ +/* 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 "__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]) + + +#ifdef __STDC__ +extern SCM scm_make_weak_vector (SCM k, SCM fill); +extern SCM scm_weak_vector (SCM l); +extern SCM scm_weak_vector_p (SCM x); +extern SCM scm_make_weak_hash_table (SCM k); +extern SCM scm_make_weak_value_hash_table (SCM k); +extern SCM scm_make_doubly_weak_hash_table (SCM k); +extern SCM scm_weak_hash_table_p (SCM x); +extern SCM scm_weak_value_hash_table_p (SCM x); +extern SCM scm_doubly_weak_hash_table_p (SCM x); +extern void scm_init_weaks (void); + +#else /* STDC */ +extern SCM scm_make_weak_vector (); +extern SCM scm_weak_vector (); +extern SCM scm_weak_vector_p (); +extern SCM scm_make_weak_hash_table (); +extern SCM scm_make_weak_value_hash_table (); +extern SCM scm_make_doubly_weak_hash_table (); +extern SCM scm_weak_hash_table_p (); +extern SCM scm_weak_value_hash_table_p (); +extern SCM scm_doubly_weak_hash_table_p (); +extern void scm_init_weaks (); + +#endif /* STDC */ + + +#endif /* WEAKSH */ |