summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--COPYING339
-rw-r--r--GUILE-VERSION4
-rw-r--r--Makefile.in294
-rwxr-xr-xconfig.guess497
-rwxr-xr-xconfig.sub833
-rwxr-xr-xconfigure868
-rw-r--r--configure.in50
-rw-r--r--ice-9/COPYING339
-rw-r--r--ice-9/ChangeLog5
-rw-r--r--ice-9/Makefile.in71
-rw-r--r--ice-9/boot-9.scm3663
-rwxr-xr-xice-9/configure722
-rw-r--r--ice-9/configure.in17
-rw-r--r--ice-9/hcons.scm76
-rw-r--r--ice-9/lineio.scm112
-rw-r--r--ice-9/mapping.scm120
-rw-r--r--ice-9/poe.scm117
-rw-r--r--ice-9/slib.scm144
-rw-r--r--ice-9/tags.scm23
-rwxr-xr-xinstall-sh238
-rw-r--r--libguile/.cvsignore8
-rw-r--r--libguile/ChangeLog1391
-rw-r--r--libguile/Makefile.in1067
-rw-r--r--libguile/__scm.h93
-rw-r--r--libguile/__scm.hd0
-rw-r--r--libguile/_scm.h28
-rw-r--r--libguile/acconfig.h49
-rw-r--r--libguile/aclocal.m419
-rw-r--r--libguile/alist.c4
-rw-r--r--libguile/alist.h2
-rw-r--r--libguile/append.c3
-rw-r--r--libguile/append.h2
-rw-r--r--libguile/arbiters.c11
-rw-r--r--libguile/arbiters.h2
-rw-r--r--libguile/async.c34
-rw-r--r--libguile/async.h3
-rw-r--r--libguile/boolean.c2
-rw-r--r--libguile/boolean.h2
-rw-r--r--libguile/chars.c7
-rw-r--r--libguile/chars.h2
-rwxr-xr-xlibguile/configure466
-rw-r--r--libguile/configure.in80
-rw-r--r--libguile/continuations.c19
-rw-r--r--libguile/continuations.h2
-rw-r--r--libguile/debug.c626
-rw-r--r--libguile/debug.h216
-rw-r--r--libguile/def.sed0
-rw-r--r--libguile/dynwind.c3
-rw-r--r--libguile/dynwind.h2
-rw-r--r--libguile/eq.c6
-rw-r--r--libguile/eq.h2
-rw-r--r--libguile/error.c279
-rw-r--r--libguile/error.h52
-rw-r--r--libguile/eval.c1301
-rw-r--r--libguile/eval.h23
-rw-r--r--libguile/extchrs.c4
-rw-r--r--libguile/extchrs.h4
-rw-r--r--libguile/feature.c57
-rw-r--r--libguile/feature.h24
-rw-r--r--libguile/filesys.c309
-rw-r--r--libguile/filesys.h4
-rw-r--r--libguile/fports.c81
-rw-r--r--libguile/fports.h5
-rw-r--r--libguile/gc.c260
-rw-r--r--libguile/gc.h71
-rw-r--r--libguile/gdb_interface.h138
-rw-r--r--libguile/gdbint.c349
-rw-r--r--libguile/gdbint.h62
-rw-r--r--libguile/genio.c11
-rw-r--r--libguile/genio.h3
-rw-r--r--libguile/gscm.c9
-rw-r--r--libguile/gscm.h2
-rw-r--r--libguile/gsubr.c4
-rw-r--r--libguile/gsubr.h2
-rw-r--r--libguile/hash.c2
-rw-r--r--libguile/hash.h2
-rw-r--r--libguile/hashtab.c4
-rw-r--r--libguile/hashtab.h2
-rw-r--r--libguile/init.c170
-rw-r--r--libguile/init.h23
-rw-r--r--libguile/ioext.c136
-rw-r--r--libguile/ioext.h6
-rw-r--r--libguile/kw.c10
-rw-r--r--libguile/kw.h2
-rw-r--r--libguile/libguile.h155
-rw-r--r--libguile/list.c338
-rw-r--r--libguile/list.h108
-rw-r--r--libguile/load.c172
-rw-r--r--libguile/load.h19
-rw-r--r--libguile/mallocs.c14
-rw-r--r--libguile/mallocs.h2
-rw-r--r--libguile/markers.c1
-rw-r--r--libguile/markers.h2
-rw-r--r--libguile/mbstrings.c9
-rw-r--r--libguile/mbstrings.h6
-rw-r--r--libguile/numbers.c177
-rw-r--r--libguile/numbers.h24
-rw-r--r--libguile/objprop.c11
-rw-r--r--libguile/objprop.h2
-rw-r--r--libguile/options.c239
-rw-r--r--libguile/options.h78
-rw-r--r--libguile/pairs.h3
-rw-r--r--libguile/ports.c71
-rw-r--r--libguile/ports.h50
-rw-r--r--libguile/posix.c401
-rw-r--r--libguile/posix.h14
-rw-r--r--libguile/print.c415
-rw-r--r--libguile/print.h44
-rw-r--r--libguile/procprop.c3
-rw-r--r--libguile/procprop.h2
-rw-r--r--libguile/procs.c32
-rw-r--r--libguile/procs.h6
-rw-r--r--libguile/ramap.c9
-rw-r--r--libguile/ramap.h6
-rw-r--r--libguile/read.c275
-rw-r--r--libguile/read.h17
-rw-r--r--libguile/root.c243
-rw-r--r--libguile/root.h56
-rw-r--r--libguile/scmconfig.h.in89
-rw-r--r--libguile/scmhob.h8
-rw-r--r--libguile/scmsigs.c7
-rw-r--r--libguile/scmsigs.h2
-rw-r--r--libguile/sequences.c1
-rw-r--r--libguile/sequences.h2
-rw-r--r--libguile/simpos.c11
-rw-r--r--libguile/simpos.h8
-rw-r--r--libguile/smob.c3
-rw-r--r--libguile/smob.h45
-rw-r--r--libguile/socket.c94
-rw-r--r--libguile/socket.h37
-rw-r--r--libguile/srcprop.c375
-rw-r--r--libguile/srcprop.h140
-rw-r--r--libguile/stackchk.c18
-rw-r--r--libguile/stackchk.h35
-rw-r--r--libguile/stime.c40
-rw-r--r--libguile/stime.h31
-rw-r--r--libguile/strerror.c32
-rw-r--r--libguile/strings.c10
-rw-r--r--libguile/strings.h10
-rw-r--r--libguile/strop.c11
-rw-r--r--libguile/strop.h2
-rw-r--r--libguile/strorder.c2
-rw-r--r--libguile/strorder.h2
-rw-r--r--libguile/strports.c10
-rw-r--r--libguile/strports.h2
-rw-r--r--libguile/struct.c153
-rw-r--r--libguile/struct.h7
-rw-r--r--libguile/symbols.c59
-rw-r--r--libguile/symbols.h31
-rw-r--r--libguile/tag.c3
-rw-r--r--libguile/tag.h2
-rw-r--r--libguile/tags.h111
-rw-r--r--libguile/throw.c252
-rw-r--r--libguile/throw.h24
-rw-r--r--libguile/unif.c149
-rw-r--r--libguile/unif.h10
-rw-r--r--libguile/variable.c13
-rw-r--r--libguile/variable.h10
-rw-r--r--libguile/vectors.c4
-rw-r--r--libguile/vectors.h8
-rw-r--r--libguile/version.c101
-rw-r--r--libguile/version.h63
-rw-r--r--libguile/vports.c9
-rw-r--r--libguile/vports.h2
-rw-r--r--libguile/weaks.c17
-rw-r--r--libguile/weaks.h10
166 files changed, 9500 insertions, 11663 deletions
diff --git a/COPYING b/COPYING
deleted file mode 100644
index 9648fb9ea..000000000
--- a/COPYING
+++ /dev/null
@@ -1,339 +0,0 @@
- GNU GENERAL PUBLIC LICENSE
- Version 2, June 1991
-
- Copyright (C) 1989, 1991, 1992, 1993 Free Software Foundation, Inc.
- 675 Mass Ave, Cambridge, MA 02139, USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- Preamble
-
- The licenses for most software are designed to take away your
-freedom to share and change it. By contrast, the GNU General Public
-License is intended to guarantee your freedom to share and change free
-software--to make sure the software is free for all its users. This
-General Public License applies to most of the Free Software
-Foundation's software and to any other program whose authors commit to
-using it. (Some other Free Software Foundation software is covered by
-the GNU Library General Public License instead.) You can apply it to
-your programs, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-this service if you wish), that you receive source code or can get it
-if you want it, that you can change the software or use pieces of it
-in new free programs; and that you know you can do these things.
-
- To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the rights.
-These restrictions translate to certain responsibilities for you if you
-distribute copies of the software, or if you modify it.
-
- For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must give the recipients all the rights that
-you have. You must make sure that they, too, receive or can get the
-source code. And you must show them these terms so they know their
-rights.
-
- We protect your rights with two steps: (1) copyright the software, and
-(2) offer you this license which gives you legal permission to copy,
-distribute and/or modify the software.
-
- Also, for each author's protection and ours, we want to make certain
-that everyone understands that there is no warranty for this free
-software. If the software is modified by someone else and passed on, we
-want its recipients to know that what they have is not the original, so
-that any problems introduced by others will not reflect on the original
-authors' reputations.
-
- Finally, any free program is threatened constantly by software
-patents. We wish to avoid the danger that redistributors of a free
-program will individually obtain patent licenses, in effect making the
-program proprietary. To prevent this, we have made it clear that any
-patent must be licensed for everyone's free use or not licensed at all.
-
- The precise terms and conditions for copying, distribution and
-modification follow.
-
- GNU GENERAL PUBLIC LICENSE
- TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
- 0. This License applies to any program or other work which contains
-a notice placed by the copyright holder saying it may be distributed
-under the terms of this General Public License. The "Program", below,
-refers to any such program or work, and a "work based on the Program"
-means either the Program or any derivative work under copyright law:
-that is to say, a work containing the Program or a portion of it,
-either verbatim or with modifications and/or translated into another
-language. (Hereinafter, translation is included without limitation in
-the term "modification".) Each licensee is addressed as "you".
-
-Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope. The act of
-running the Program is not restricted, and the output from the Program
-is covered only if its contents constitute a work based on the
-Program (independent of having been made by running the Program).
-Whether that is true depends on what the Program does.
-
- 1. You may copy and distribute verbatim copies of the Program's
-source code as you receive it, in any medium, provided that you
-conspicuously and appropriately publish on each copy an appropriate
-copyright notice and disclaimer of warranty; keep intact all the
-notices that refer to this License and to the absence of any warranty;
-and give any other recipients of the Program a copy of this License
-along with the Program.
-
-You may charge a fee for the physical act of transferring a copy, and
-you may at your option offer warranty protection in exchange for a fee.
-
- 2. You may modify your copy or copies of the Program or any portion
-of it, thus forming a work based on the Program, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
-
- a) You must cause the modified files to carry prominent notices
- stating that you changed the files and the date of any change.
-
- b) You must cause any work that you distribute or publish, that in
- whole or in part contains or is derived from the Program or any
- part thereof, to be licensed as a whole at no charge to all third
- parties under the terms of this License.
-
- c) If the modified program normally reads commands interactively
- when run, you must cause it, when started running for such
- interactive use in the most ordinary way, to print or display an
- announcement including an appropriate copyright notice and a
- notice that there is no warranty (or else, saying that you provide
- a warranty) and that users may redistribute the program under
- these conditions, and telling the user how to view a copy of this
- License. (Exception: if the Program itself is interactive but
- does not normally print such an announcement, your work based on
- the Program is not required to print an announcement.)
-
-These requirements apply to the modified work as a whole. If
-identifiable sections of that work are not derived from the Program,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works. But when you
-distribute the same sections as part of a whole which is a work based
-on the Program, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Program.
-
-In addition, mere aggregation of another work not based on the Program
-with the Program (or with a work based on the Program) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
- 3. You may copy and distribute the Program (or a work based on it,
-under Section 2) in object code or executable form under the terms of
-Sections 1 and 2 above provided that you also do one of the following:
-
- a) Accompany it with the complete corresponding machine-readable
- source code, which must be distributed under the terms of Sections
- 1 and 2 above on a medium customarily used for software interchange; or,
-
- b) Accompany it with a written offer, valid for at least three
- years, to give any third party, for a charge no more than your
- cost of physically performing source distribution, a complete
- machine-readable copy of the corresponding source code, to be
- distributed under the terms of Sections 1 and 2 above on a medium
- customarily used for software interchange; or,
-
- c) Accompany it with the information you received as to the offer
- to distribute corresponding source code. (This alternative is
- allowed only for noncommercial distribution and only if you
- received the program in object code or executable form with such
- an offer, in accord with Subsection b above.)
-
-The source code for a work means the preferred form of the work for
-making modifications to it. For an executable work, complete source
-code means all the source code for all modules it contains, plus any
-associated interface definition files, plus the scripts used to
-control compilation and installation of the executable. However, as a
-special exception, the source code distributed need not include
-anything that is normally distributed (in either source or binary
-form) with the major components (compiler, kernel, and so on) of the
-operating system on which the executable runs, unless that component
-itself accompanies the executable.
-
-If distribution of executable or object code is made by offering
-access to copy from a designated place, then offering equivalent
-access to copy the source code from the same place counts as
-distribution of the source code, even though third parties are not
-compelled to copy the source along with the object code.
-
- 4. You may not copy, modify, sublicense, or distribute the Program
-except as expressly provided under this License. Any attempt
-otherwise to copy, modify, sublicense or distribute the Program is
-void, and will automatically terminate your rights under this License.
-However, parties who have received copies, or rights, from you under
-this License will not have their licenses terminated so long as such
-parties remain in full compliance.
-
- 5. You are not required to accept this License, since you have not
-signed it. However, nothing else grants you permission to modify or
-distribute the Program or its derivative works. These actions are
-prohibited by law if you do not accept this License. Therefore, by
-modifying or distributing the Program (or any work based on the
-Program), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Program or works based on it.
-
- 6. Each time you redistribute the Program (or any work based on the
-Program), the recipient automatically receives a license from the
-original licensor to copy, distribute or modify the Program subject to
-these terms and conditions. You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties to
-this License.
-
- 7. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Program at all. For example, if a patent
-license would not permit royalty-free redistribution of the Program by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Program.
-
-If any portion of this section is held invalid or unenforceable under
-any particular circumstance, the balance of the section is intended to
-apply and the section as a whole is intended to apply in other
-circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system, which is
-implemented by public license practices. Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-
- 8. If the distribution and/or use of the Program is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Program under this License
-may add an explicit geographical distribution limitation excluding
-those countries, so that distribution is permitted only in or among
-countries not thus excluded. In such case, this License incorporates
-the limitation as if written in the body of this License.
-
- 9. The Free Software Foundation may publish revised and/or new versions
-of the General Public License from time to time. Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
-Each version is given a distinguishing version number. If the Program
-specifies a version number of this License which applies to it and "any
-later version", you have the option of following the terms and conditions
-either of that version or of any later version published by the Free
-Software Foundation. If the Program does not specify a version number of
-this License, you may choose any version ever published by the Free Software
-Foundation.
-
- 10. If you wish to incorporate parts of the Program into other free
-programs whose distribution conditions are different, write to the author
-to ask for permission. For software which is copyrighted by the Free
-Software Foundation, write to the Free Software Foundation; we sometimes
-make exceptions for this. Our decision will be guided by the two goals
-of preserving the free status of all derivatives of our free software and
-of promoting the sharing and reuse of software generally.
-
- NO WARRANTY
-
- 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
-FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
-OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
-PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
-OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
-TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
-PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
-REPAIR OR CORRECTION.
-
- 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
-REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
-INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
-OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
-TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
-YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
-PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGES.
-
- END OF TERMS AND CONDITIONS
-
- Appendix: How to Apply These Terms to Your New Programs
-
- If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
- To do so, attach the following notices to the program. It is safest
-to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
- <one line to give the program's name and a brief idea of what it does.>
- Copyright (C) 19yy <name of author>
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-Also add information on how to contact you by electronic and paper mail.
-
-If the program is interactive, make it output a short notice like this
-when it starts in an interactive mode:
-
- Gnomovision version 69, Copyright (C) 19yy name of author
- Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
- This is free software, and you are welcome to redistribute it
- under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License. Of course, the commands you use may
-be called something other than `show w' and `show c'; they could even be
-mouse-clicks or menu items--whatever suits your program.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the program, if
-necessary. Here is a sample; alter the names:
-
- Yoyodyne, Inc., hereby disclaims all copyright interest in the program
- `Gnomovision' (which makes passes at compilers) written by James Hacker.
-
- <signature of Ty Coon>, 1 April 1989
- Ty Coon, President of Vice
-
-This General Public License does not permit incorporating your program into
-proprietary programs. If your program is a subroutine library, you may
-consider it more useful to permit linking proprietary applications with the
-library. If this is what you want to do, use the GNU Library General
-Public License instead of this License.
diff --git a/GUILE-VERSION b/GUILE-VERSION
deleted file mode 100644
index 891b63016..000000000
--- a/GUILE-VERSION
+++ /dev/null
@@ -1,4 +0,0 @@
-GUILE_MAJOR_VERSION=1
-GUILE_MINOR_VERSION=0
-GUILE_VERSION=$GUILE_MAJOR_VERSION.$GUILE_MINOR_VERSION
-
diff --git a/Makefile.in b/Makefile.in
deleted file mode 100644
index c2334e3f7..000000000
--- a/Makefile.in
+++ /dev/null
@@ -1,294 +0,0 @@
-# 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
deleted file mode 100755
index a3d6a9f1b..000000000
--- a/config.guess
+++ /dev/null
@@ -1,497 +0,0 @@
-#! /bin/sh
-# Attempt to guess a canonical system name.
-# Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
-#
-# This file is free software; you can redistribute it and/or modify it
-# under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful, but
-# WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-# General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-#
-# As a special exception to the GNU General Public License, if you
-# distribute this file as part of a program that contains a
-# configuration script generated by Autoconf, you may include it under
-# the same distribution terms that you use for the rest of that program.
-
-# Written by Per Bothner <bothner@cygnus.com>.
-# The master version of this file is at the FSF in /home/gd/gnu/lib.
-#
-# This script attempts to guess a canonical system name similar to
-# config.sub. If it succeeds, it prints the system name on stdout, and
-# exits with 0. Otherwise, it exits with 1.
-#
-# The plan is that this can be called by configure scripts if you
-# don't specify an explicit system type (host/target name).
-#
-# Only a few systems have been added to this list; please add others
-# (but try to keep the structure clean).
-#
-
-# This is needed to find uname on a Pyramid OSx when run in the BSD universe.
-# (ghazi@noc.rutgers.edu 8/24/94.)
-if (test -f /.attbin/uname) >/dev/null 2>&1 ; then
- PATH=$PATH:/.attbin ; export PATH
-fi
-
-UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown
-UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown
-UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
-UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown
-
-trap 'rm -f dummy.c dummy.o dummy; exit 1' 1 2 15
-
-# Note: order is significant - the case branches are not exclusive.
-
-case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
- alpha:OSF1:V*:*)
- # After 1.2, OSF1 uses "V1.3" for uname -r.
- echo alpha-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^V//'`
- exit 0 ;;
- alpha:OSF1:*:*)
- # 1.2 uses "1.2" for uname -r.
- echo alpha-dec-osf${UNAME_RELEASE}
- exit 0 ;;
- amiga:NetBSD:*:*)
- echo m68k-cbm-netbsd${UNAME_RELEASE}
- exit 0 ;;
- arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
- echo arm-acorn-riscix${UNAME_RELEASE}
- exit 0;;
- Pyramid*:OSx*:*:*)
- if test "`(/bin/universe) 2>/dev/null`" = att ; then
- echo pyramid-pyramid-sysv3
- else
- echo pyramid-pyramid-bsd
- fi
- exit 0 ;;
- sun4*:SunOS:5.*:*)
- echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
- exit 0 ;;
- sun4*:SunOS:6*:*)
- # According to config.sub, this is the proper way to canonicalize
- # SunOS6. Hard to guess exactly what SunOS6 will be like, but
- # it's likely to be more like Solaris than SunOS4.
- echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
- exit 0 ;;
- sun4*:SunOS:*:*)
- case "`/usr/bin/arch -k`" in
- Series*|S4*)
- UNAME_RELEASE=`uname -v`
- ;;
- esac
- # Japanese Language versions have a version number like `4.1.3-JL'.
- echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`
- exit 0 ;;
- sun3*:SunOS:*:*)
- echo m68k-sun-sunos${UNAME_RELEASE}
- exit 0 ;;
- RISC*:ULTRIX:*:*)
- echo mips-dec-ultrix${UNAME_RELEASE}
- exit 0 ;;
- VAX*:ULTRIX*:*:*)
- echo vax-dec-ultrix${UNAME_RELEASE}
- exit 0 ;;
- mips:*:5*:RISCos)
- echo mips-mips-riscos${UNAME_RELEASE}
- exit 0 ;;
- m88k:CX/UX:7*:*)
- echo m88k-harris-cxux7
- exit 0 ;;
- m88k:*:4*:R4*)
- echo m88k-motorola-sysv4
- exit 0 ;;
- m88k:*:3*:R3*)
- echo m88k-motorola-sysv3
- exit 0 ;;
- AViiON:dgux:*:*)
- if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx \
- -o ${TARGET_BINARY_INTERFACE}x = x ] ; then
- echo m88k-dg-dgux${UNAME_RELEASE}
- else
- echo m88k-dg-dguxbcs${UNAME_RELEASE}
- fi
- exit 0 ;;
- M88*:DolphinOS:*:*) # DolphinOS (SVR3)
- echo m88k-dolphin-sysv3
- exit 0 ;;
- M88*:*:R3*:*)
- # Delta 88k system running SVR3
- echo m88k-motorola-sysv3
- exit 0 ;;
- XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)
- echo m88k-tektronix-sysv3
- exit 0 ;;
- Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)
- echo m68k-tektronix-bsd
- exit 0 ;;
- *:IRIX*:*:*)
- echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`
- exit 0 ;;
- ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.
- echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id
- exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX '
- i[34]86:AIX:*:*)
- echo i386-ibm-aix
- exit 0 ;;
- *:AIX:2:3)
- if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then
- sed 's/^ //' << EOF >dummy.c
- #include <sys/systemcfg.h>
-
- main()
- {
- if (!__power_pc())
- exit(1);
- puts("powerpc-ibm-aix3.2.5");
- exit(0);
- }
-EOF
- ${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0
- rm -f dummy.c dummy
- echo rs6000-ibm-aix3.2.5
- elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then
- echo rs6000-ibm-aix3.2.4
- else
- echo rs6000-ibm-aix3.2
- fi
- exit 0 ;;
- *:AIX:*:4)
- if /usr/sbin/lsattr -EHl proc0 | grep POWER >/dev/null 2>&1; then
- IBM_ARCH=rs6000
- else
- IBM_ARCH=powerpc
- fi
- if grep bos410 /usr/include/stdio.h >/dev/null 2>&1; then
- IBM_REV=4.1
- elif grep bos411 /usr/include/stdio.h >/dev/null 2>&1; then
- IBM_REV=4.1.1
- else
- IBM_REV=4.${UNAME_RELEASE}
- fi
- echo ${IBM_ARCH}-ibm-aix${IBM_REV}
- exit 0 ;;
- *:AIX:*:*)
- echo rs6000-ibm-aix
- exit 0 ;;
- ibmrt:4.4BSD:*|romp-ibm:BSD:*)
- echo romp-ibm-bsd4.4
- exit 0 ;;
- ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC NetBSD and
- echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to
- exit 0 ;; # report: romp-ibm BSD 4.3
- *:BOSX:*:*)
- echo rs6000-bull-bosx
- exit 0 ;;
- DPX/2?00:B.O.S.:*:*)
- echo m68k-bull-sysv3
- exit 0 ;;
- 9000/[34]??:4.3bsd:1.*:*)
- echo m68k-hp-bsd
- exit 0 ;;
- hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)
- echo m68k-hp-bsd4.4
- exit 0 ;;
- 9000/[3478]??:HP-UX:*:*)
- case "${UNAME_MACHINE}" in
- 9000/31? ) HP_ARCH=m68000 ;;
- 9000/[34]?? ) HP_ARCH=m68k ;;
- 9000/7?? | 9000/8?7 ) HP_ARCH=hppa1.1 ;;
- 9000/8?? ) HP_ARCH=hppa1.0 ;;
- esac
- HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
- echo ${HP_ARCH}-hp-hpux${HPUX_REV}
- exit 0 ;;
- 3050*:HI-UX:*:*)
- sed 's/^ //' << EOF >dummy.c
- #include <unistd.h>
- int
- main ()
- {
- long cpu = sysconf (_SC_CPU_VERSION);
- /* The order matters, because CPU_IS_HP_MC68K erroneously returns
- true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct
- results, however. */
- if (CPU_IS_PA_RISC (cpu))
- {
- switch (cpu)
- {
- case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break;
- case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break;
- case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break;
- default: puts ("hppa-hitachi-hiuxwe2"); break;
- }
- }
- else if (CPU_IS_HP_MC68K (cpu))
- puts ("m68k-hitachi-hiuxwe2");
- else puts ("unknown-hitachi-hiuxwe2");
- exit (0);
- }
-EOF
- ${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0
- rm -f dummy.c dummy
- echo unknown-hitachi-hiuxwe2
- exit 0 ;;
- 9000/7??:4.3bsd:*:* | 9000/8?7:4.3bsd:*:* )
- echo hppa1.1-hp-bsd
- exit 0 ;;
- 9000/8??:4.3bsd:*:*)
- echo hppa1.0-hp-bsd
- exit 0 ;;
- hp7??:OSF1:*:* | hp8?7:OSF1:*:* )
- echo hppa1.1-hp-osf
- exit 0 ;;
- hp8??:OSF1:*:*)
- echo hppa1.0-hp-osf
- exit 0 ;;
- C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)
- echo c1-convex-bsd
- exit 0 ;;
- C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)
- if getsysinfo -f scalar_acc
- then echo c32-convex-bsd
- else echo c2-convex-bsd
- fi
- exit 0 ;;
- C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)
- echo c34-convex-bsd
- exit 0 ;;
- C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)
- echo c38-convex-bsd
- exit 0 ;;
- C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)
- echo c4-convex-bsd
- exit 0 ;;
- CRAY*X-MP:UNICOS:*:*)
- echo xmp-cray-unicos
- exit 0 ;;
- CRAY*Y-MP:UNICOS:*:*)
- echo ymp-cray-unicos
- exit 0 ;;
- CRAY-2:UNICOS:*:*)
- echo cray2-cray-unicos
- exit 0 ;;
- hp3[0-9][05]:NetBSD:*:*)
- echo m68k-hp-netbsd${UNAME_RELEASE}
- exit 0 ;;
- i[34]86:BSD/386:*:* | *:BSD/OS:*:*)
- echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}
- exit 0 ;;
- *:FreeBSD:*:*)
- echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
- exit 0 ;;
- *:NetBSD:*:*)
- echo ${UNAME_MACHINE}-unknown-netbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
- exit 0 ;;
- *:GNU:*:*)
- echo `echo ${UNAME_MACHINE}|sed -e 's,/.*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
- exit 0 ;;
- *:Linux:*:*)
- echo ${UNAME_MACHINE}-unknown-linux
- exit 0 ;;
-# ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. earlier versions
-# are messed up and put the nodename in both sysname and nodename.
- i[34]86:DYNIX/ptx:4*:*)
- echo i386-sequent-sysv4
- exit 0 ;;
- i[34]86:*:4.*:* | i[34]86:SYSTEM_V:4.*:*)
- if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then
- echo ${UNAME_MACHINE}-univel-sysv${UNAME_RELEASE}
- else
- echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}
- fi
- exit 0 ;;
- i[34]86:*:3.2:*)
- if test -f /usr/options/cb.name; then
- UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`
- echo ${UNAME_MACHINE}-unknown-isc$UNAME_REL
- elif /bin/uname -X 2>/dev/null >/dev/null ; then
- UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')`
- (/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486
- echo ${UNAME_MACHINE}-unknown-sco$UNAME_REL
- else
- echo ${UNAME_MACHINE}-unknown-sysv32
- fi
- exit 0 ;;
- Intel:Mach:3*:*)
- echo i386-unknown-mach3
- exit 0 ;;
- paragon:*:*:*)
- echo i860-intel-osf1
- exit 0 ;;
- i860:*:4.*:*) # i860-SVR4
- if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then
- echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4
- else # Add other i860-SVR4 vendors below as they are discovered.
- echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4
- fi
- exit 0 ;;
- mini*:CTIX:SYS*5:*)
- # "miniframe"
- echo m68010-convergent-sysv
- exit 0 ;;
- M680[234]0:*:R3V[567]*:*)
- test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;;
- 3[34]??:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0)
- uname -p 2>/dev/null | grep 86 >/dev/null \
- && echo i486-ncr-sysv4.3 && exit 0 ;;
- 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
- uname -p 2>/dev/null | grep 86 >/dev/null \
- && echo i486-ncr-sysv4 && exit 0 ;;
- m680[234]0:LynxOS:2.2*:*)
- echo m68k-lynx-lynxos${UNAME_RELEASE}
- exit 0 ;;
- mc68030:UNIX_System_V:4.*:*)
- echo m68k-atari-sysv4
- exit 0 ;;
- i[34]86:LynxOS:2.2*:*)
- echo i386-lynx-lynxos${UNAME_RELEASE}
- exit 0 ;;
- TSUNAMI:LynxOS:2.2*:*)
- echo sparc-lynx-lynxos${UNAME_RELEASE}
- exit 0 ;;
- rs6000:LynxOS:2.2*:*)
- echo rs6000-lynx-lynxos${UNAME_RELEASE}
- exit 0 ;;
- RM*:SINIX-*:*:*)
- echo mips-sni-sysv4
- exit 0 ;;
- *:SINIX-*:*:*)
- if uname -p 2>/dev/null >/dev/null ; then
- UNAME_MACHINE=`(uname -p) 2>/dev/null`
- echo ${UNAME_MACHINE}-sni-sysv4
- else
- echo ns32k-sni-sysv
- fi
- exit 0 ;;
-esac
-
-#echo '(No uname command or uname output not recognized.)' 1>&2
-#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2
-
-cat >dummy.c <<EOF
-main ()
-{
-#if defined (sony)
-#if defined (MIPSEB)
- /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed,
- I don't know.... */
- printf ("mips-sony-bsd\n"); exit (0);
-#else
-#include <sys/param.h>
- printf ("m68k-sony-newsos%s\n",
-#ifdef NEWSOS4
- "4"
-#else
- ""
-#endif
- ); exit (0);
-#endif
-#endif
-
-#if defined (__arm) && defined (__acorn) && defined (__unix)
- printf ("arm-acorn-riscix"); exit (0);
-#endif
-
-#if defined (hp300) && !defined (hpux)
- printf ("m68k-hp-bsd\n"); exit (0);
-#endif
-
-#if defined (NeXT)
-#if !defined (__ARCHITECTURE__)
-#define __ARCHITECTURE__ "m68k"
-#endif
- int version;
- version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;
- printf ("%s-next-nextstep%s\n", __ARCHITECTURE__, version==2 ? "2" : "3");
- exit (0);
-#endif
-
-#if defined (MULTIMAX) || defined (n16)
-#if defined (UMAXV)
- printf ("ns32k-encore-sysv\n"); exit (0);
-#else
-#if defined (CMU)
- printf ("ns32k-encore-mach\n"); exit (0);
-#else
- printf ("ns32k-encore-bsd\n"); exit (0);
-#endif
-#endif
-#endif
-
-#if defined (__386BSD__)
- printf ("i386-unknown-bsd\n"); exit (0);
-#endif
-
-#if defined (sequent)
-#if defined (i386)
- printf ("i386-sequent-dynix\n"); exit (0);
-#endif
-#if defined (ns32000)
- printf ("ns32k-sequent-dynix\n"); exit (0);
-#endif
-#endif
-
-#if defined (_SEQUENT_)
- printf ("i386-sequent-ptx\n"); exit (0);
-#endif
-
-#if defined (vax)
-#if !defined (ultrix)
- printf ("vax-dec-bsd\n"); exit (0);
-#else
- printf ("vax-dec-ultrix\n"); exit (0);
-#endif
-#endif
-
-#if defined (alliant) && defined (i860)
- printf ("i860-alliant-bsd\n"); exit (0);
-#endif
-
- exit (1);
-}
-EOF
-
-${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy && rm dummy.c dummy && exit 0
-rm -f dummy.c dummy
-
-# Apollos put the system type in the environment.
-
-test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; }
-
-# Convex versions that predate uname can use getsysinfo(1)
-
-if [ -x /usr/convex/getsysinfo ]
-then
- case `getsysinfo -f cpu_type` in
- c1*)
- echo c1-convex-bsd
- exit 0 ;;
- c2*)
- if getsysinfo -f scalar_acc
- then echo c32-convex-bsd
- else echo c2-convex-bsd
- fi
- exit 0 ;;
- c34*)
- echo c34-convex-bsd
- exit 0 ;;
- c38*)
- echo c38-convex-bsd
- exit 0 ;;
- c4*)
- echo c4-convex-bsd
- exit 0 ;;
- esac
-fi
-
-#echo '(Unable to guess system type)' 1>&2
-
-exit 1
diff --git a/config.sub b/config.sub
deleted file mode 100755
index 5641cc1ce..000000000
--- a/config.sub
+++ /dev/null
@@ -1,833 +0,0 @@
-#! /bin/sh
-# Configuration validation subroutine script, version 1.1.
-# Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
-# This file is (in principle) common to ALL GNU software.
-# The presence of a machine in this file suggests that SOME GNU software
-# can handle that machine. It does not imply ALL GNU software can.
-#
-# This file is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-# As a special exception to the GNU General Public License, if you
-# distribute this file as part of a program that contains a
-# configuration script generated by Autoconf, you may include it under
-# the same distribution terms that you use for the rest of that program.
-
-# Configuration subroutine to validate and canonicalize a configuration type.
-# Supply the specified configuration type as an argument.
-# If it is invalid, we print an error message on stderr and exit with code 1.
-# Otherwise, we print the canonical config type on stdout and succeed.
-
-# This file is supposed to be the same for all GNU packages
-# and recognize all the CPU types, system types and aliases
-# that are meaningful with *any* GNU software.
-# Each package is responsible for reporting which valid configurations
-# it does not support. The user should be able to distinguish
-# a failure to support a valid configuration from a meaningless
-# configuration.
-
-# The goal of this file is to map all the various variations of a given
-# machine specification into a single specification in the form:
-# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
-# It is wrong to echo any other type of specification.
-
-if [ x$1 = x ]
-then
- echo Configuration name missing. 1>&2
- echo "Usage: $0 CPU-MFR-OPSYS" 1>&2
- echo "or $0 ALIAS" 1>&2
- echo where ALIAS is a recognized configuration type. 1>&2
- exit 1
-fi
-
-# First pass through any local machine types.
-case $1 in
- *local*)
- echo $1
- exit 0
- ;;
- *)
- ;;
-esac
-
-# Separate what the user gave into CPU-COMPANY and OS (if any).
-basic_machine=`echo $1 | sed 's/-[^-]*$//'`
-if [ $basic_machine != $1 ]
-then os=`echo $1 | sed 's/.*-/-/'`
-else os=; fi
-
-### Let's recognize common machines as not being operating systems so
-### that things like config.sub decstation-3100 work. We also
-### recognize some manufacturers as not being operating systems, so we
-### can provide default operating systems below.
-case $os in
- -sun*os*)
- # Prevent following clause from handling this invalid input.
- ;;
- -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \
- -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \
- -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \
- -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
- -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
- -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp )
- os=
- basic_machine=$1
- ;;
- -hiux*)
- os=-hiuxwe2
- ;;
- -sco4)
- os=-sco3.2v4
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
- ;;
- -sco3.2.[4-9]*)
- os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
- ;;
- -sco3.2v[4-9]*)
- # Don't forget version if it is 3.2v4 or newer.
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
- ;;
- -sco*)
- os=-sco3.2v2
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
- ;;
- -isc)
- os=-isc2.2
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
- ;;
- -clix*)
- basic_machine=clipper-intergraph
- ;;
- -isc*)
- basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
- ;;
- -lynx*)
- os=-lynxos
- ;;
- -ptx*)
- basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'`
- ;;
- -windowsnt*)
- os=`echo $os | sed -e 's/windowsnt/winnt/'`
- ;;
-esac
-
-# Decode aliases for certain CPU-COMPANY combinations.
-case $basic_machine in
- # Recognize the basic CPU types without company name.
- # Some are omitted here because they have special meanings below.
- tahoe | i[345]86 | i860 | m68k | m68000 | m88k | ns32k | arm | pyramid \
- | tron | a29k | 580 | i960 | h8300 | hppa1.0 | hppa1.1 \
- | alpha | we32k | ns16k | clipper | sparclite | i370 | sh \
- | powerpc | sparc64 | 1750a | dsp16xx | mips64 | mipsel \
- | pdp11 | mips64el | mips64orion | mips64orionel \
- | sparc)
- basic_machine=$basic_machine-unknown
- ;;
- # Object if more than one company name word.
- *-*-*)
- echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
- exit 1
- ;;
- # Recognize the basic CPU types with company name.
- vax-* | tahoe-* | i[345]86-* | i860-* | m68k-* | m68000-* | m88k-* \
- | sparc-* | ns32k-* | fx80-* | arm-* | c[123]* \
- | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \
- | none-* | 580-* | cray2-* | h8300-* | i960-* | xmp-* | ymp-* \
- | hppa1.0-* | hppa1.1-* | alpha-* | we32k-* | cydra-* | ns16k-* \
- | pn-* | np1-* | xps100-* | clipper-* | orion-* | sparclite-* \
- | pdp11-* | sh-* | powerpc-* | sparc64-* | mips64-* | mipsel-* \
- | mips64el-* | mips64orion-* | mips64orionel-*)
- ;;
- # Recognize the various machine names and aliases which stand
- # for a CPU type and a company and sometimes even an OS.
- 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)
- basic_machine=m68000-att
- ;;
- 3b*)
- basic_machine=we32k-att
- ;;
- alliant | fx80)
- basic_machine=fx80-alliant
- ;;
- altos | altos3068)
- basic_machine=m68k-altos
- ;;
- am29k)
- basic_machine=a29k-none
- os=-bsd
- ;;
- amdahl)
- basic_machine=580-amdahl
- os=-sysv
- ;;
- amiga | amiga-*)
- basic_machine=m68k-cbm
- ;;
- amigados)
- basic_machine=m68k-cbm
- os=-amigados
- ;;
- amigaunix | amix)
- basic_machine=m68k-cbm
- os=-sysv4
- ;;
- apollo68)
- basic_machine=m68k-apollo
- os=-sysv
- ;;
- balance)
- basic_machine=ns32k-sequent
- os=-dynix
- ;;
- convex-c1)
- basic_machine=c1-convex
- os=-bsd
- ;;
- convex-c2)
- basic_machine=c2-convex
- os=-bsd
- ;;
- convex-c32)
- basic_machine=c32-convex
- os=-bsd
- ;;
- convex-c34)
- basic_machine=c34-convex
- os=-bsd
- ;;
- convex-c38)
- basic_machine=c38-convex
- os=-bsd
- ;;
- cray | ymp)
- basic_machine=ymp-cray
- os=-unicos
- ;;
- cray2)
- basic_machine=cray2-cray
- os=-unicos
- ;;
- crds | unos)
- basic_machine=m68k-crds
- ;;
- da30 | da30-*)
- basic_machine=m68k-da30
- ;;
- decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)
- basic_machine=mips-dec
- ;;
- delta | 3300 | motorola-3300 | motorola-delta \
- | 3300-motorola | delta-motorola)
- basic_machine=m68k-motorola
- ;;
- delta88)
- basic_machine=m88k-motorola
- os=-sysv3
- ;;
- dpx20 | dpx20-*)
- basic_machine=rs6000-bull
- os=-bosx
- ;;
- dpx2* | dpx2*-bull)
- basic_machine=m68k-bull
- os=-sysv3
- ;;
- ebmon29k)
- basic_machine=a29k-amd
- os=-ebmon
- ;;
- elxsi)
- basic_machine=elxsi-elxsi
- os=-bsd
- ;;
- encore | umax | mmax)
- basic_machine=ns32k-encore
- ;;
- fx2800)
- basic_machine=i860-alliant
- ;;
- genix)
- basic_machine=ns32k-ns
- ;;
- gmicro)
- basic_machine=tron-gmicro
- os=-sysv
- ;;
- h3050r* | hiux*)
- basic_machine=hppa1.1-hitachi
- os=-hiuxwe2
- ;;
- h8300hms)
- basic_machine=h8300-hitachi
- os=-hms
- ;;
- harris)
- basic_machine=m88k-harris
- os=-sysv3
- ;;
- hp300-*)
- basic_machine=m68k-hp
- ;;
- hp300bsd)
- basic_machine=m68k-hp
- os=-bsd
- ;;
- hp300hpux)
- basic_machine=m68k-hp
- os=-hpux
- ;;
- hp9k2[0-9][0-9] | hp9k31[0-9])
- basic_machine=m68000-hp
- ;;
- hp9k3[2-9][0-9])
- basic_machine=m68k-hp
- ;;
- hp9k7[0-9][0-9] | hp7[0-9][0-9] | hp9k8[0-9]7 | hp8[0-9]7)
- basic_machine=hppa1.1-hp
- ;;
- hp9k8[0-9][0-9] | hp8[0-9][0-9])
- basic_machine=hppa1.0-hp
- ;;
- i370-ibm* | ibm*)
- basic_machine=i370-ibm
- os=-mvs
- ;;
-# I'm not sure what "Sysv32" means. Should this be sysv3.2?
- i[345]86v32)
- basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
- os=-sysv32
- ;;
- i[345]86v4*)
- basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
- os=-sysv4
- ;;
- i[345]86v)
- basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
- os=-sysv
- ;;
- i[345]86sol2)
- basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
- os=-solaris2
- ;;
- iris | iris4d)
- basic_machine=mips-sgi
- case $os in
- -irix*)
- ;;
- *)
- os=-irix4
- ;;
- esac
- ;;
- isi68 | isi)
- basic_machine=m68k-isi
- os=-sysv
- ;;
- m88k-omron*)
- basic_machine=m88k-omron
- ;;
- magnum | m3230)
- basic_machine=mips-mips
- os=-sysv
- ;;
- merlin)
- basic_machine=ns32k-utek
- os=-sysv
- ;;
- miniframe)
- basic_machine=m68000-convergent
- ;;
- mips3*-*)
- basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`
- ;;
- mips3*)
- basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
- ;;
- ncr3000)
- basic_machine=i486-ncr
- os=-sysv4
- ;;
- news | news700 | news800 | news900)
- basic_machine=m68k-sony
- os=-newsos
- ;;
- news1000)
- basic_machine=m68030-sony
- os=-newsos
- ;;
- news-3600 | risc-news)
- basic_machine=mips-sony
- os=-newsos
- ;;
- next | m*-next )
- basic_machine=m68k-next
- case $os in
- -nextstep* )
- ;;
- -ns2*)
- os=-nextstep2
- ;;
- *)
- os=-nextstep3
- ;;
- esac
- ;;
- nh3000)
- basic_machine=m68k-harris
- os=-cxux
- ;;
- nh[45]000)
- basic_machine=m88k-harris
- os=-cxux
- ;;
- nindy960)
- basic_machine=i960-intel
- os=-nindy
- ;;
- np1)
- basic_machine=np1-gould
- ;;
- pa-hitachi)
- basic_machine=hppa1.1-hitachi
- os=-hiuxwe2
- ;;
- paragon)
- basic_machine=i860-intel
- os=-osf
- ;;
- pbd)
- basic_machine=sparc-tti
- ;;
- pbb)
- basic_machine=m68k-tti
- ;;
- pc532 | pc532-*)
- basic_machine=ns32k-pc532
- ;;
- pentium-*)
- # We will change tis to say i586 once there has been
- # time for various packages to start to recognize that.
- basic_machine=i486-`echo $basic_machine | sed 's/^[^-]*-//'`
- ;;
- pn)
- basic_machine=pn-gould
- ;;
- ps2)
- basic_machine=i386-ibm
- ;;
- rm[46]00)
- basic_machine=mips-siemens
- ;;
- rtpc | rtpc-*)
- basic_machine=romp-ibm
- ;;
- sequent)
- basic_machine=i386-sequent
- ;;
- sh)
- basic_machine=sh-hitachi
- os=-hms
- ;;
- sps7)
- basic_machine=m68k-bull
- os=-sysv2
- ;;
- spur)
- basic_machine=spur-unknown
- ;;
- sun2)
- basic_machine=m68000-sun
- ;;
- sun2os3)
- basic_machine=m68000-sun
- os=-sunos3
- ;;
- sun2os4)
- basic_machine=m68000-sun
- os=-sunos4
- ;;
- sun3os3)
- basic_machine=m68k-sun
- os=-sunos3
- ;;
- sun3os4)
- basic_machine=m68k-sun
- os=-sunos4
- ;;
- sun4os3)
- basic_machine=sparc-sun
- os=-sunos3
- ;;
- sun4os4)
- basic_machine=sparc-sun
- os=-sunos4
- ;;
- sun4sol2)
- basic_machine=sparc-sun
- os=-solaris2
- ;;
- sun3 | sun3-*)
- basic_machine=m68k-sun
- ;;
- sun4)
- basic_machine=sparc-sun
- ;;
- sun386 | sun386i | roadrunner)
- basic_machine=i386-sun
- ;;
- symmetry)
- basic_machine=i386-sequent
- os=-dynix
- ;;
- tower | tower-32)
- basic_machine=m68k-ncr
- ;;
- udi29k)
- basic_machine=a29k-amd
- os=-udi
- ;;
- ultra3)
- basic_machine=a29k-nyu
- os=-sym1
- ;;
- vaxv)
- basic_machine=vax-dec
- os=-sysv
- ;;
- vms)
- basic_machine=vax-dec
- os=-vms
- ;;
- vxworks960)
- basic_machine=i960-wrs
- os=-vxworks
- ;;
- vxworks68)
- basic_machine=m68k-wrs
- os=-vxworks
- ;;
- xmp)
- basic_machine=xmp-cray
- os=-unicos
- ;;
- xps | xps100)
- basic_machine=xps100-honeywell
- ;;
- none)
- basic_machine=none-none
- os=-none
- ;;
-
-# Here we handle the default manufacturer of certain CPU types. It is in
-# some cases the only manufacturer, in others, it is the most popular.
- mips)
- basic_machine=mips-mips
- ;;
- romp)
- basic_machine=romp-ibm
- ;;
- rs6000)
- basic_machine=rs6000-ibm
- ;;
- vax)
- basic_machine=vax-dec
- ;;
- pdp11)
- basic_machine=pdp11-dec
- ;;
- we32k)
- basic_machine=we32k-att
- ;;
- sparc)
- basic_machine=sparc-sun
- ;;
- cydra)
- basic_machine=cydra-cydrome
- ;;
- orion)
- basic_machine=orion-highlevel
- ;;
- orion105)
- basic_machine=clipper-highlevel
- ;;
- *)
- echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
- exit 1
- ;;
-esac
-
-# Here we canonicalize certain aliases for manufacturers.
-case $basic_machine in
- *-digital*)
- basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'`
- ;;
- *-commodore*)
- basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'`
- ;;
- *)
- ;;
-esac
-
-# Decode manufacturer-specific aliases for certain operating systems.
-
-if [ x"$os" != x"" ]
-then
-case $os in
- # -solaris* is a basic system type, with this one exception.
- -solaris1 | -solaris1.*)
- os=`echo $os | sed -e 's|solaris1|sunos4|'`
- ;;
- -solaris)
- os=-solaris2
- ;;
- -unixware* | svr4*)
- os=-sysv4
- ;;
- -gnu/linux*)
- os=`echo $os | sed -e 's|gnu/linux|linux|'`
- ;;
- # First accept the basic system types.
- # The portable systems comes first.
- # Each alternative must end in a *, to match a version number.
- # -sysv* is not here because it comes later, after sysvr4.
- -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
- | -vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[345]* \
- | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \
- | -amigados* | -msdos* | -newsos* | -unicos* | -aos* \
- | -nindy* | -vxworks* | -ebmon* | -hms* | -mvs* | -clix* \
- | -riscos* | -linux* | -uniplus* | -iris* | -rtu* | -xenix* \
- | -hiux* | -386bsd* | -netbsd* | -freebsd* | -riscix* \
- | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* \
- | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta | -udi | -eabi)
- ;;
- -sunos5*)
- os=`echo $os | sed -e 's|sunos5|solaris2|'`
- ;;
- -sunos6*)
- os=`echo $os | sed -e 's|sunos6|solaris3|'`
- ;;
- -osfrose*)
- os=-osfrose
- ;;
- -osf*)
- os=-osf
- ;;
- -utek*)
- os=-bsd
- ;;
- -dynix*)
- os=-bsd
- ;;
- -acis*)
- os=-aos
- ;;
- -ctix* | -uts*)
- os=-sysv
- ;;
- # Preserve the version number of sinix5.
- -sinix5.*)
- os=`echo $os | sed -e 's|sinix|sysv|'`
- ;;
- -sinix*)
- os=-sysv4
- ;;
- -triton*)
- os=-sysv3
- ;;
- -oss*)
- os=-sysv3
- ;;
- -svr4)
- os=-sysv4
- ;;
- -svr3)
- os=-sysv3
- ;;
- -sysvr4)
- os=-sysv4
- ;;
- # This must come after -sysvr4.
- -sysv*)
- ;;
- -xenix)
- os=-xenix
- ;;
- -none)
- ;;
- *)
- # Get rid of the `-' at the beginning of $os.
- os=`echo $os | sed 's/[^-]*-//'`
- echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2
- exit 1
- ;;
-esac
-else
-
-# Here we handle the default operating systems that come with various machines.
-# The value should be what the vendor currently ships out the door with their
-# machine or put another way, the most popular os provided with the machine.
-
-# Note that if you're going to try to match "-MANUFACTURER" here (say,
-# "-sun"), then you have to tell the case statement up towards the top
-# that MANUFACTURER isn't an operating system. Otherwise, code above
-# will signal an error saying that MANUFACTURER isn't an operating
-# system, and we'll never get to this point.
-
-case $basic_machine in
- *-acorn)
- os=-riscix1.2
- ;;
- pdp11-*)
- os=-none
- ;;
- *-dec | vax-*)
- os=-ultrix4.2
- ;;
- m68*-apollo)
- os=-domain
- ;;
- i386-sun)
- os=-sunos4.0.2
- ;;
- m68000-sun)
- os=-sunos3
- # This also exists in the configure program, but was not the
- # default.
- # os=-sunos4
- ;;
- *-tti) # must be before sparc entry or we get the wrong os.
- os=-sysv3
- ;;
- sparc-* | *-sun)
- os=-sunos4.1.1
- ;;
- *-ibm)
- os=-aix
- ;;
- *-hp)
- os=-hpux
- ;;
- *-hitachi)
- os=-hiux
- ;;
- i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent)
- os=-sysv
- ;;
- *-cbm)
- os=-amigados
- ;;
- *-dg)
- os=-dgux
- ;;
- *-dolphin)
- os=-sysv3
- ;;
- m68k-ccur)
- os=-rtu
- ;;
- m88k-omron*)
- os=-luna
- ;;
- *-sequent)
- os=-ptx
- ;;
- *-crds)
- os=-unos
- ;;
- *-ns)
- os=-genix
- ;;
- i370-*)
- os=-mvs
- ;;
- *-next)
- os=-nextstep3
- ;;
- *-gould)
- os=-sysv
- ;;
- *-highlevel)
- os=-bsd
- ;;
- *-encore)
- os=-bsd
- ;;
- *-sgi)
- os=-irix
- ;;
- *-siemens)
- os=-sysv4
- ;;
- *-masscomp)
- os=-rtu
- ;;
- *)
- os=-none
- ;;
-esac
-fi
-
-# Here we handle the case where we know the os, and the CPU type, but not the
-# manufacturer. We pick the logical manufacturer.
-vendor=unknown
-case $basic_machine in
- *-unknown)
- case $os in
- -riscix*)
- vendor=acorn
- ;;
- -sunos*)
- vendor=sun
- ;;
- -lynxos*)
- vendor=lynx
- ;;
- -aix*)
- vendor=ibm
- ;;
- -hpux*)
- vendor=hp
- ;;
- -hiux*)
- vendor=hitachi
- ;;
- -unos*)
- vendor=crds
- ;;
- -dgux*)
- vendor=dg
- ;;
- -luna*)
- vendor=omron
- ;;
- -genix*)
- vendor=ns
- ;;
- -mvs*)
- vendor=ibm
- ;;
- -ptx*)
- vendor=sequent
- ;;
- -vxworks*)
- vendor=wrs
- ;;
- esac
- basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`
- ;;
-esac
-
-echo $basic_machine$os
diff --git a/configure b/configure
deleted file mode 100755
index 098617faf..000000000
--- a/configure
+++ /dev/null
@@ -1,868 +0,0 @@
-#! /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
deleted file mode 100644
index 6ea5ef4c6..000000000
--- a/configure.in
+++ /dev/null
@@ -1,50 +0,0 @@
-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
deleted file mode 100644
index 9648fb9ea..000000000
--- a/ice-9/COPYING
+++ /dev/null
@@ -1,339 +0,0 @@
- GNU GENERAL PUBLIC LICENSE
- Version 2, June 1991
-
- Copyright (C) 1989, 1991, 1992, 1993 Free Software Foundation, Inc.
- 675 Mass Ave, Cambridge, MA 02139, USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- Preamble
-
- The licenses for most software are designed to take away your
-freedom to share and change it. By contrast, the GNU General Public
-License is intended to guarantee your freedom to share and change free
-software--to make sure the software is free for all its users. This
-General Public License applies to most of the Free Software
-Foundation's software and to any other program whose authors commit to
-using it. (Some other Free Software Foundation software is covered by
-the GNU Library General Public License instead.) You can apply it to
-your programs, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-this service if you wish), that you receive source code or can get it
-if you want it, that you can change the software or use pieces of it
-in new free programs; and that you know you can do these things.
-
- To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the rights.
-These restrictions translate to certain responsibilities for you if you
-distribute copies of the software, or if you modify it.
-
- For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must give the recipients all the rights that
-you have. You must make sure that they, too, receive or can get the
-source code. And you must show them these terms so they know their
-rights.
-
- We protect your rights with two steps: (1) copyright the software, and
-(2) offer you this license which gives you legal permission to copy,
-distribute and/or modify the software.
-
- Also, for each author's protection and ours, we want to make certain
-that everyone understands that there is no warranty for this free
-software. If the software is modified by someone else and passed on, we
-want its recipients to know that what they have is not the original, so
-that any problems introduced by others will not reflect on the original
-authors' reputations.
-
- Finally, any free program is threatened constantly by software
-patents. We wish to avoid the danger that redistributors of a free
-program will individually obtain patent licenses, in effect making the
-program proprietary. To prevent this, we have made it clear that any
-patent must be licensed for everyone's free use or not licensed at all.
-
- The precise terms and conditions for copying, distribution and
-modification follow.
-
- GNU GENERAL PUBLIC LICENSE
- TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
- 0. This License applies to any program or other work which contains
-a notice placed by the copyright holder saying it may be distributed
-under the terms of this General Public License. The "Program", below,
-refers to any such program or work, and a "work based on the Program"
-means either the Program or any derivative work under copyright law:
-that is to say, a work containing the Program or a portion of it,
-either verbatim or with modifications and/or translated into another
-language. (Hereinafter, translation is included without limitation in
-the term "modification".) Each licensee is addressed as "you".
-
-Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope. The act of
-running the Program is not restricted, and the output from the Program
-is covered only if its contents constitute a work based on the
-Program (independent of having been made by running the Program).
-Whether that is true depends on what the Program does.
-
- 1. You may copy and distribute verbatim copies of the Program's
-source code as you receive it, in any medium, provided that you
-conspicuously and appropriately publish on each copy an appropriate
-copyright notice and disclaimer of warranty; keep intact all the
-notices that refer to this License and to the absence of any warranty;
-and give any other recipients of the Program a copy of this License
-along with the Program.
-
-You may charge a fee for the physical act of transferring a copy, and
-you may at your option offer warranty protection in exchange for a fee.
-
- 2. You may modify your copy or copies of the Program or any portion
-of it, thus forming a work based on the Program, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
-
- a) You must cause the modified files to carry prominent notices
- stating that you changed the files and the date of any change.
-
- b) You must cause any work that you distribute or publish, that in
- whole or in part contains or is derived from the Program or any
- part thereof, to be licensed as a whole at no charge to all third
- parties under the terms of this License.
-
- c) If the modified program normally reads commands interactively
- when run, you must cause it, when started running for such
- interactive use in the most ordinary way, to print or display an
- announcement including an appropriate copyright notice and a
- notice that there is no warranty (or else, saying that you provide
- a warranty) and that users may redistribute the program under
- these conditions, and telling the user how to view a copy of this
- License. (Exception: if the Program itself is interactive but
- does not normally print such an announcement, your work based on
- the Program is not required to print an announcement.)
-
-These requirements apply to the modified work as a whole. If
-identifiable sections of that work are not derived from the Program,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works. But when you
-distribute the same sections as part of a whole which is a work based
-on the Program, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Program.
-
-In addition, mere aggregation of another work not based on the Program
-with the Program (or with a work based on the Program) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
- 3. You may copy and distribute the Program (or a work based on it,
-under Section 2) in object code or executable form under the terms of
-Sections 1 and 2 above provided that you also do one of the following:
-
- a) Accompany it with the complete corresponding machine-readable
- source code, which must be distributed under the terms of Sections
- 1 and 2 above on a medium customarily used for software interchange; or,
-
- b) Accompany it with a written offer, valid for at least three
- years, to give any third party, for a charge no more than your
- cost of physically performing source distribution, a complete
- machine-readable copy of the corresponding source code, to be
- distributed under the terms of Sections 1 and 2 above on a medium
- customarily used for software interchange; or,
-
- c) Accompany it with the information you received as to the offer
- to distribute corresponding source code. (This alternative is
- allowed only for noncommercial distribution and only if you
- received the program in object code or executable form with such
- an offer, in accord with Subsection b above.)
-
-The source code for a work means the preferred form of the work for
-making modifications to it. For an executable work, complete source
-code means all the source code for all modules it contains, plus any
-associated interface definition files, plus the scripts used to
-control compilation and installation of the executable. However, as a
-special exception, the source code distributed need not include
-anything that is normally distributed (in either source or binary
-form) with the major components (compiler, kernel, and so on) of the
-operating system on which the executable runs, unless that component
-itself accompanies the executable.
-
-If distribution of executable or object code is made by offering
-access to copy from a designated place, then offering equivalent
-access to copy the source code from the same place counts as
-distribution of the source code, even though third parties are not
-compelled to copy the source along with the object code.
-
- 4. You may not copy, modify, sublicense, or distribute the Program
-except as expressly provided under this License. Any attempt
-otherwise to copy, modify, sublicense or distribute the Program is
-void, and will automatically terminate your rights under this License.
-However, parties who have received copies, or rights, from you under
-this License will not have their licenses terminated so long as such
-parties remain in full compliance.
-
- 5. You are not required to accept this License, since you have not
-signed it. However, nothing else grants you permission to modify or
-distribute the Program or its derivative works. These actions are
-prohibited by law if you do not accept this License. Therefore, by
-modifying or distributing the Program (or any work based on the
-Program), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Program or works based on it.
-
- 6. Each time you redistribute the Program (or any work based on the
-Program), the recipient automatically receives a license from the
-original licensor to copy, distribute or modify the Program subject to
-these terms and conditions. You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties to
-this License.
-
- 7. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Program at all. For example, if a patent
-license would not permit royalty-free redistribution of the Program by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Program.
-
-If any portion of this section is held invalid or unenforceable under
-any particular circumstance, the balance of the section is intended to
-apply and the section as a whole is intended to apply in other
-circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system, which is
-implemented by public license practices. Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-
- 8. If the distribution and/or use of the Program is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Program under this License
-may add an explicit geographical distribution limitation excluding
-those countries, so that distribution is permitted only in or among
-countries not thus excluded. In such case, this License incorporates
-the limitation as if written in the body of this License.
-
- 9. The Free Software Foundation may publish revised and/or new versions
-of the General Public License from time to time. Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
-Each version is given a distinguishing version number. If the Program
-specifies a version number of this License which applies to it and "any
-later version", you have the option of following the terms and conditions
-either of that version or of any later version published by the Free
-Software Foundation. If the Program does not specify a version number of
-this License, you may choose any version ever published by the Free Software
-Foundation.
-
- 10. If you wish to incorporate parts of the Program into other free
-programs whose distribution conditions are different, write to the author
-to ask for permission. For software which is copyrighted by the Free
-Software Foundation, write to the Free Software Foundation; we sometimes
-make exceptions for this. Our decision will be guided by the two goals
-of preserving the free status of all derivatives of our free software and
-of promoting the sharing and reuse of software generally.
-
- NO WARRANTY
-
- 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
-FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
-OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
-PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
-OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
-TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
-PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
-REPAIR OR CORRECTION.
-
- 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
-REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
-INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
-OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
-TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
-YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
-PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGES.
-
- END OF TERMS AND CONDITIONS
-
- Appendix: How to Apply These Terms to Your New Programs
-
- If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
- To do so, attach the following notices to the program. It is safest
-to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
- <one line to give the program's name and a brief idea of what it does.>
- Copyright (C) 19yy <name of author>
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-Also add information on how to contact you by electronic and paper mail.
-
-If the program is interactive, make it output a short notice like this
-when it starts in an interactive mode:
-
- Gnomovision version 69, Copyright (C) 19yy name of author
- Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
- This is free software, and you are welcome to redistribute it
- under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License. Of course, the commands you use may
-be called something other than `show w' and `show c'; they could even be
-mouse-clicks or menu items--whatever suits your program.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the program, if
-necessary. Here is a sample; alter the names:
-
- Yoyodyne, Inc., hereby disclaims all copyright interest in the program
- `Gnomovision' (which makes passes at compilers) written by James Hacker.
-
- <signature of Ty Coon>, 1 April 1989
- Ty Coon, President of Vice
-
-This General Public License does not permit incorporating your program into
-proprietary programs. If your program is a subroutine library, you may
-consider it more useful to permit linking proprietary applications with the
-library. If this is what you want to do, use the GNU Library General
-Public License instead of this License.
diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
deleted file mode 100644
index fe69f1e0b..000000000
--- a/ice-9/ChangeLog
+++ /dev/null
@@ -1,5 +0,0 @@
-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
deleted file mode 100644
index 318dc4a56..000000000
--- a/ice-9/Makefile.in
+++ /dev/null
@@ -1,71 +0,0 @@
-# Copyright (C) 1995 Free Software Foundation, Inc.
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this software; see the file COPYING. If not, write to
-# the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-#
-
-
-
-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
deleted file mode 100644
index fa55e9a1d..000000000
--- a/ice-9/boot-9.scm
+++ /dev/null
@@ -1,3663 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-;;; This file is the first thing loaded into Guile. It adds many mundane
-;;; definitions and a few that are interesting.
-;;;
-;;; The module system (hence the hierarchical namespace) are defined in this
-;;; file.
-;;;
-
-
-
-;; {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
deleted file mode 100755
index 25b98d1a0..000000000
--- a/ice-9/configure
+++ /dev/null
@@ -1,722 +0,0 @@
-#! /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
deleted file mode 100644
index cb1926a87..000000000
--- a/ice-9/configure.in
+++ /dev/null
@@ -1,17 +0,0 @@
-#
-# 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
deleted file mode 100644
index febd5e8c7..000000000
--- a/ice-9/hcons.scm
+++ /dev/null
@@ -1,76 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-(define-module #/ice-9/hcons)
-
-
-;;; {Eq? hash-consing}
-;;;
-;;; A hash conser maintains a private universe of pairs s.t. if
-;;; two cons calls pass eq? arguments, the pairs returned are eq?.
-;;;
-;;; A hash conser does not contribute life to the pairs it returns.
-;;;
-
-(define-public (hashq-cons-hash pair n)
- (modulo (logxor (hashq (car pair) 4194303)
- (hashq (cdr pair) 4194303))
- n))
-
-(define-public (hashq-cons-assoc key l)
- (and l (or (and (pair? l)
- (pair? (car l))
- (pair? (caar l))
- (eq? (car key) (caaar l))
- (eq? (cdr key) (cdaar l))
- (car l))
- (hashq-cons-assoc key (cdr l)))))
-
-(define-public (hashq-cons-get-handle table key)
- (hashx-get-handle hashq-cons-hash hashq-cons-assoc table key #f))
-
-(define-public (hashq-cons-create-handle! table key init)
- (hashx-create-handle! hashq-cons-hash hashq-cons-assoc table key init))
-
-(define-public (hashq-cons-ref table key)
- (hashx-ref hashq-cons-hash hashq-cons-assoc table key #f))
-
-(define-public (hashq-cons-set! table key val)
- (hashx-set! hashq-cons-hash hashq-cons-assoc table key val))
-
-(define-public (hashq-cons table a d)
- (car (hashq-cons-create-handle! table (cons a d) #f)))
-
-(define-public (hashq-conser hash-tab-or-size)
- (let ((table (if (vector? hash-tab-or-size)
- hash-tab-or-size
- (make-doubly-weak-hash-table hash-tab-or-size))))
- (lambda (a d) (hashq-cons table a d))))
-
-
-
-
-(define-public (make-gc-buffer n)
- (let ((ring (make-list n #f)))
- (append! ring ring)
- (lambda (next)
- (set-car! ring next)
- (set! ring (cdr ring))
- next)))
diff --git a/ice-9/lineio.scm b/ice-9/lineio.scm
deleted file mode 100644
index ffde88608..000000000
--- a/ice-9/lineio.scm
+++ /dev/null
@@ -1,112 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-
-(define-module #/ice-9/lineio)
-
-
-;;; {Line Buffering Input Ports}
-;;;
-;;; [This is a work-around to get past certain deficiencies in the capabilities
-;;; of ports. Eventually, ports should be fixed and this module nuked.]
-;;;
-;;; A line buffering input port supports:
-;;;
-;;; read-string which returns the next line of input
-;;; unread-string which pushes a line back onto the stream
-;;;
-;;; Normally a "line" is all characters up to and including a newline.
-;;; If lines are put back using unread-string, they can be broken arbitrarily
-;;; -- that is, read-string returns strings passed to unread-string (or
-;;; shared substrings of them).
-;;;
-
-;; read-string port
-;; unread-string port str
-;; Read (or buffer) a line from PORT.
-;;
-;; Not all ports support these functions -- only those with
-;; 'unread-string and 'read-string properties, bound to hooks
-;; implementing these functions.
-;;
-(define-public (unread-string str line-buffering-input-port)
- ((object-property line-buffering-input-port 'unread-string) str))
-
-;;
-(define-public (read-string line-buffering-input-port)
- ((object-property line-buffering-input-port 'read-string)))
-
-
-(define-public (lineio-port? port)
- (not (not (object-property port 'read-string))))
-
-;; make-line-buffering-input-port port
-;; Return a wrapper for PORT. The wrapper handles read-string/unread-string.
-;;
-;; The port returned by this function reads newline terminated lines from PORT.
-;; It buffers these characters internally, and parsels them out via calls
-;; to read-char, read-string, and unread-string.
-;;
-
-(define-public (make-line-buffering-input-port underlying-port)
- (let* (;; buffers - a list of strings put back by unread-string or cached
- ;; using read-line.
- ;;
- (buffers '())
-
- ;; getc - return the next character from a buffer or from the underlying
- ;; port.
- ;;
- (getc (lambda ()
- (if (not buffers)
- (read-char underlying-port)
- (let ((c (string-ref (car buffers))))
- (if (= 1 (string-length (car buffers)))
- (set! buffers (cdr buffers))
- (set-car! buffers (make-shared-substring (car buffers) 1)))
- c))))
-
- (propogate-close (lambda () (close-port underlying-port)))
-
- (self (make-soft-port (vector #f #f #f getc propogate-close) "r"))
-
- (unread-string (lambda (str)
- (and (< 0 (string-length str))
- (if (ungetc-char-ready? self)
- (set! buffers (append! (list str (string (read-char self))) buffers))
- (set! buffers (cons str buffers))))))
-
- (read-string (lambda ()
- (cond
- (buffers (let ((answer (car buffers)))
- (set! buffers (cdr buffers))
- answer))
-
- ((ungetc-char-ready? self) (read-line self 'include-newline))
-
- (else (read-line underlying-port 'include-newline)))))
-
- )
-
- (set-object-property! self 'unread-string unread-string)
- (set-object-property! self 'read-string read-string)
- self))
-
-
diff --git a/ice-9/mapping.scm b/ice-9/mapping.scm
deleted file mode 100644
index 9d9bb7aa6..000000000
--- a/ice-9/mapping.scm
+++ /dev/null
@@ -1,120 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-
-(define-module #/ice-9/mapping
- :use-module #/ice-9/poe)
-
-(define-public mapping-hooks-type (make-record-type 'mapping-hooks '(get-handle
- create-handle
- remove)))
-
-
-(define-public make-mapping-hooks (perfect-funcq 17 (record-constructor mapping-hooks-type)))
-(define-public mapping-hooks? (record-predicate mapping-hooks-type))
-(define-public mapping-hooks-get-handle (record-accessor mapping-hooks-type 'get-handle))
-(define-public mapping-hooks-create-handle (record-accessor mapping-hooks-type 'create-handle))
-(define-public mapping-hooks-remove (record-accessor mapping-hooks-type 'remove))
-
-(define-public mapping-type (make-record-type 'mapping '(hooks data)))
-(define-public make-mapping (record-constructor mapping-type))
-(define-public mapping? (record-predicate mapping-type))
-(define-public mapping-hooks (record-accessor mapping-type 'hooks))
-(define-public mapping-data (record-accessor mapping-type 'data))
-(define-public set-mapping-hooks! (record-modifier mapping-type 'hooks))
-(define-public set-mapping-data! (record-modifier mapping-type 'data))
-
-(define-public (mapping-get-handle map key)
- ((mapping-hooks-get-handle (mapping-hooks map)) map key))
-(define-public (mapping-create-handle! map key . opts)
- (apply (mapping-hooks-create-handle (mapping-hooks map)) map key opts))
-(define-public (mapping-remove! map key)
- ((mapping-hooks-remove (mapping-hooks map)) map key))
-
-(define-public (mapping-ref map key . dflt)
- (cond
- ((mapping-get-handle map key) => cdr)
- (dflt => car)
- (else #f)))
-
-(define-public (mapping-set! map key val)
- (set-cdr! (mapping-create-handle! map key #f) val))
-
-
-
-(define-public hash-table-mapping-hooks
- (let ((wrap (lambda (proc) (lambda (1st . rest) (apply proc (mapping-data 1st) rest)))))
-
- (perfect-funcq 17
- (lambda (hash-proc assoc-proc delete-proc)
- (let ((procs (list hash-proc assoc-proc delete-proc)))
- (cond
- ((equal? procs `(,hashq ,assq ,delq!))
- (make-mapping-hooks (wrap hashq-get-handle)
- (wrap hashq-create-handle!)
- (wrap hashq-remove!)))
- ((equal? procs `(,hashv ,assv ,delv!))
- (make-mapping-hooks (wrap hashv-get-handle)
- (wrap hashv-create-handle!)
- (wrap hashv-remove!)))
- ((equal? procs `(,hash ,assoc ,delete!))
- (make-mapping-hooks (wrap hash-get-handle)
- (wrap hash-create-handle!)
- (wrap hash-remove!)))
- (else
- (make-mapping-hooks (wrap
- (lambda (table key)
- (hashx-get-handle hash-proc assoc-proc table key)))
- (wrap
- (lambda (table key)
- (hashx-create-handle hash-proc assoc-proc table key)))
- (wrap
- (lambda (table key)
- (hashx-get-handle hash-proc assoc-proc delete-proc table key)))))))))))
-
-(define-public (make-hash-table-mapping table hash-proc assoc-proc delete-proc)
- (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc delete-proc) table))
-
-(define-public (hash-table-mapping . options)
- (let* ((size (or (and options (number? (car options)) (car options))
- 71))
- (hash-proc (or (kw-arg-ref options :hash-proc) hash))
- (assoc-proc (or (kw-arg-ref options :assoc-proc)
- (cond
- ((eq? hash-proc hash) assoc)
- ((eq? hash-proc hashv) assv)
- ((eq? hash-proc hashq) assq)
- (else (error 'hash-table-mapping
- "Hash-procedure specified with no known assoc function."
- hash-proc)))))
- (delete-proc (or (kw-arg-ref options :delete-proc)
- (cond
- ((eq? hash-proc hash) delete!)
- ((eq? hash-proc hashv) delv!)
- ((eq? hash-proc hashq) delq!)
- (else (error 'hash-table-mapping
- "Hash-procedure specified with no known delete function."
- hash-proc)))))
- (table-constructor (or (kw-arg-ref options :table-constructor) 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
deleted file mode 100644
index b594ebe13..000000000
--- a/ice-9/poe.scm
+++ /dev/null
@@ -1,117 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-(define-module #/ice-9/poe
- :use-module #/ice-9/hcons)
-
-
-
-
-;;; {Pure Functions}
-;;;
-;;; A pure function (of some sort) is characterized by two equality
-;;; relations: one on argument lists and one on return values.
-;;; A pure function is one that when applied to equal arguments lists
-;;; yields equal results.
-;;;
-;;; If the equality relationship on return values can be eq?, it may make
-;;; sense to cache values returned by the function. Choosing the right
-;;; equality relation on arguments is tricky.
-;;;
-
-
-;;; {pure-funcq}
-;;;
-;;; The simplest case of pure functions are those in which results
-;;; are only certainly eq? if all of the arguments are. These functions
-;;; are called "pure-funcq", for obvious reasons.
-;;;
-
-
-(define funcq-memo (make-weak-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
deleted file mode 100644
index 3178598fd..000000000
--- a/ice-9/slib.scm
+++ /dev/null
@@ -1,144 +0,0 @@
-;;; installed-scm-file
-(define-module #/ice-9/slib)
-
-
-
-(define (eval-load <filename> evl)
- (if (not (file-exists? <filename>))
- (set! <filename> (string-append <filename> (scheme-file-suffix))))
- (call-with-input-file <filename>
- (lambda (port)
- (let ((old-load-pathname *load-pathname*))
- (set! *load-pathname* <filename>)
- (do ((o (read port #t read-sharp) (read port #t read-sharp)))
- ((eof-object? o))
- (evl o))
- (set! *load-pathname* old-load-pathname)))))
-
-
-
-(define slib:exit quit)
-(define slib:error error)
-(define slib:eval eval)
-(define defmacro:eval eval)
-(define logical:logand logand)
-(define logical:logior logior)
-(define logical:logxor logxor)
-(define logical:lognot lognot)
-(define logical:ash ash)
-(define logical:logcount logcount)
-(define logical:integer-length integer-length)
-(define logical:bit-extract bit-extract)
-(define logical:integer-expt integer-expt)
-(define logical:ipow-by-squaring ipow-by-squaring)
-(define slib:eval-load eval-load)
-(define slib:tab #\tab)
-(define slib:form-feed #\page)
-
-(define slib:features
- (append '(source
- eval
- abort
- alist
- defmacro
- delay
- dynamic-wind
- full-continuation
- hash
- hash-table
- line-i/o
- logical
- multiarg/and-
- multiarg-apply
- promise
- rev2-procedures
- rev4-optional-procedures
- string-port
- with-file)
-
- (if (defined? getenv)
- '(getenv)
- '())
-
- (if (defined? current-time)
- '(current-time)
- '())
-
- (if (defined? system)
- '(system)
- '())
-
- (if (defined? array?)
- '(array)
- '())
-
- (if (defined? char-ready?)
- '(char-ready?)
- '())
-
- (if (defined? array-for-each)
- '(array-for-each)
- '())
-
- (if (and (string->number "0.0") (inexact? (string->number "0.0")))
- '(inexact)
- '())
-
- (if (rational? (string->number "1/19"))
- '(rational)
- '())
-
- (if (real? (string->number "0.0"))
- '(real)
- ())
-
- (if (complex? (string->number "1+i"))
- '(complex)
- '())
-
- (let ((n (string->number "9999999999999999999999999999999")))
- (if (and n (exact? n))
- '(bignum)
- '()))))
-
-
-(define slib-module (current-module))
-
-(define (slib:load name)
- (save-module-excursion
- (lambda ()
- (set-current-module slib-module)
- (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
deleted file mode 100644
index 58b7425b4..000000000
--- a/ice-9/tags.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-
-(define-module #/ice-9/tags)
-
diff --git a/install-sh b/install-sh
deleted file mode 100755
index ab74c882e..000000000
--- a/install-sh
+++ /dev/null
@@ -1,238 +0,0 @@
-#!/bin/sh
-#
-# install - install a program, script, or datafile
-# This comes from X11R5.
-#
-# Calling this script install-sh is preferred over install.sh, to prevent
-# `make' implicit rules from creating a file called install from it
-# when there is no Makefile.
-#
-# This script is compatible with the BSD install script, but was written
-# from scratch.
-#
-
-
-# set DOITPROG to echo to test this script
-
-# Don't use :- since 4.3BSD and earlier shells don't like it.
-doit="${DOITPROG-}"
-
-
-# put in absolute paths if you don't have them in your path; or use env. vars.
-
-mvprog="${MVPROG-mv}"
-cpprog="${CPPROG-cp}"
-chmodprog="${CHMODPROG-chmod}"
-chownprog="${CHOWNPROG-chown}"
-chgrpprog="${CHGRPPROG-chgrp}"
-stripprog="${STRIPPROG-strip}"
-rmprog="${RMPROG-rm}"
-mkdirprog="${MKDIRPROG-mkdir}"
-
-tranformbasename=""
-transform_arg=""
-instcmd="$mvprog"
-chmodcmd="$chmodprog 0755"
-chowncmd=""
-chgrpcmd=""
-stripcmd=""
-rmcmd="$rmprog -f"
-mvcmd="$mvprog"
-src=""
-dst=""
-dir_arg=""
-
-while [ x"$1" != x ]; do
- case $1 in
- -c) instcmd="$cpprog"
- shift
- continue;;
-
- -d) dir_arg=true
- shift
- continue;;
-
- -m) chmodcmd="$chmodprog $2"
- shift
- shift
- continue;;
-
- -o) chowncmd="$chownprog $2"
- shift
- shift
- continue;;
-
- -g) chgrpcmd="$chgrpprog $2"
- shift
- shift
- continue;;
-
- -s) stripcmd="$stripprog"
- shift
- continue;;
-
- -t=*) transformarg=`echo $1 | sed 's/-t=//'`
- shift
- continue;;
-
- -b=*) transformbasename=`echo $1 | sed 's/-b=//'`
- shift
- continue;;
-
- *) if [ x"$src" = x ]
- then
- src=$1
- else
- # this colon is to work around a 386BSD /bin/sh bug
- :
- dst=$1
- fi
- shift
- continue;;
- esac
-done
-
-if [ x"$src" = x ]
-then
- echo "install: no input file specified"
- exit 1
-else
- true
-fi
-
-if [ x"$dir_arg" != x ]; then
- dst=$src
- src=""
-
- if [ -d $dst ]; then
- instcmd=:
- else
- instcmd=mkdir
- fi
-else
-
-# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
-# might cause directories to be created, which would be especially bad
-# if $src (and thus $dsttmp) contains '*'.
-
- if [ -f $src -o -d $src ]
- then
- true
- else
- echo "install: $src does not exist"
- exit 1
- fi
-
- if [ x"$dst" = x ]
- then
- echo "install: no destination specified"
- exit 1
- else
- true
- fi
-
-# If destination is a directory, append the input filename; if your system
-# does not like double slashes in filenames, you may need to add some logic
-
- if [ -d $dst ]
- then
- dst="$dst"/`basename $src`
- else
- true
- fi
-fi
-
-## this sed command emulates the dirname command
-dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
-
-# Make sure that the destination directory exists.
-# this part is taken from Noah Friedman's mkinstalldirs script
-
-# Skip lots of stat calls in the usual case.
-if [ ! -d "$dstdir" ]; then
-defaultIFS='
-'
-IFS="${IFS-${defaultIFS}}"
-
-oIFS="${IFS}"
-# Some sh's can't handle IFS=/ for some reason.
-IFS='%'
-set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
-IFS="${oIFS}"
-
-pathcomp=''
-
-while [ $# -ne 0 ] ; do
- pathcomp="${pathcomp}${1}"
- shift
-
- if [ ! -d "${pathcomp}" ] ;
- then
- $mkdirprog "${pathcomp}"
- else
- true
- fi
-
- pathcomp="${pathcomp}/"
-done
-fi
-
-if [ x"$dir_arg" != x ]
-then
- $doit $instcmd $dst &&
-
- if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
- if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
- if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
- if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
-else
-
-# If we're going to rename the final executable, determine the name now.
-
- if [ x"$transformarg" = x ]
- then
- dstfile=`basename $dst`
- else
- dstfile=`basename $dst $transformbasename |
- sed $transformarg`$transformbasename
- fi
-
-# don't allow the sed command to completely eliminate the filename
-
- if [ x"$dstfile" = x ]
- then
- dstfile=`basename $dst`
- else
- true
- fi
-
-# Make a temp file name in the proper directory.
-
- dsttmp=$dstdir/#inst.$$#
-
-# Move or copy the file name to the temp name
-
- $doit $instcmd $src $dsttmp &&
-
- trap "rm -f ${dsttmp}" 0 &&
-
-# and set any options; do chmod last to preserve setuid bits
-
-# If any of these fail, we abort the whole thing. If we want to
-# ignore errors from any of these, just make sure not to ignore
-# errors from the above "$doit $instcmd $src $dsttmp" command.
-
- if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
- if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
- if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
- if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
-
-# Now rename the file to the real destination.
-
- $doit $rmcmd -f $dstdir/$dstfile &&
- $doit $mvcmd $dsttmp $dstdir/$dstfile
-
-fi &&
-
-
-exit 0
diff --git a/libguile/.cvsignore b/libguile/.cvsignore
new file mode 100644
index 000000000..e4632e405
--- /dev/null
+++ b/libguile/.cvsignore
@@ -0,0 +1,8 @@
+Makefile
+config.log
+config.status
+config.cache
+fd.h
+scmconfig.h
+*.x
+libpath.h \ No newline at end of file
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 1726e3cb5..4cf28910f 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,1380 @@
+Sat Oct 12 21:49:29 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * error.c, eval.c, load.c, stackchk.c: use scm_error not lgh_error.
+
+ * __scm.h (lgh_error): removed, lgh shouldn't be in libguile.
+
+ * stime.c, stime.h: use SCM_P method.
+
+Sat Oct 12 16:16:25 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * eval.c (scm_nconc2last): Don't accept an empty list; apply must
+ be given at least two arguments. Insist that lst's last element
+ be a list, but don't make any requirements of its predecessors.
+
+Fri Oct 11 03:58:25 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * eval.c (scm_nconc2last): Revert last change; there seems to be
+ other stuff going on here.
+
+Fri Oct 11 02:43:59 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * eval.c (scm_nconc2last): Make sure that each element of lst
+ (which is a list of argument lists, except for the tail) is a
+ proper list, i.e., finite and terminated by '().
+
+Thu Oct 10 21:09:13 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * unif.c (scm_ra_set_contp): Localize `inc' declaration.
+ Clarifies flow.
+
+ * struct.c (scm_make_struct, scm_make_vtable_vtable): Use the
+ symbolic name for the tag, scm_tc3_cons_gloc, instead of just
+ saying "1".
+
+ * vectors.c (scm_make_vector): Fill vectors with the undefined
+ value, to help make Guile Scheme code more portable to other
+ Schemes.
+
+ * symbols.c (scm_intern_obarray_soft, scm_sysintern): Doc fixes.
+ * symbols.h, tags.h: Doc fixes.
+
+Wed Oct 9 19:39:29 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * async.c (scm_take_signal): Doc fixes.
+
+Mon Oct 7 22:30:34 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * numbers.c (scm_divbigint): When the remainder is zero, we don't
+ want to subtract it from the modulus; we just want to leave it
+ alone.
+
+Mon Oct 7 00:14:17 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * init.c (scm_boot_guile_1): Bugfix: i --> base in argument to
+ `scm_init_threads'.
+
+ * throw.h (scm_catch_apply): Removed the `lazyp' argument.
+
+ * throw.c (scm_catch_apply): Finished implementation of
+ `lazy-catch'.
+
+Sun Oct 6 05:26:05 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scm_sys_select): move SCM_ALLOW_INTS past the sreturn
+ check.
+ (scm_init_filesys): set "i/o-extensions" feature.
+ include feature.h.
+
+Sat Oct 5 12:22:00 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (root.o): Correct dependencies.
+
+Sat Oct 5 18:40:42 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * Makefile.in: Added dependency entry for root.o.
+
+ * continuations.c, debug.[ch], eval.c, gscm.c init.c, root.c,
+ throw.c: Renamed last_debug_info_frame -> scm_last_debug_frame.
+
+ * init.c (scm_start_stack): Set initial root continuation number
+ to 0.
+
+ * procs.c: New function: scm_thunk_p.
+
+ * procs.h: Added declarations of scm_thunk_p.
+
+ * root.c: Renamed `call-with-new-root' -->
+ `call-with-dynamic-root'.
+ (cwdr): Removed allocation of new root state. This should be done
+ separately by use of scm_make_root.
+ (scm_apply_with_dynamic_root): New function: Does what it
+ sounds like. Needed when spawning threads.
+
+ * root.h: Added member last_debug_frame to root state.
+ Added #include "libguile/debug.h"
+
+ * throw.c: Renamed scm_catch --> scm_catch_apply and added more
+ arguments. The motivation is that code in root.c needs catch
+ functionality, and we want to avoid code duplication.
+ New functions: scm_catch, scm_lazy_catch. These are wrappers for
+ scm_catch_apply. scm_lazy_catch is intended to introduce catch
+ handlers that run without popping the stack into the dynwind
+ chain.
+
+ * throw.h: Added prototypes for scm_catch_apply and
+ scm_lazy_catch.
+
+Thu Oct 3 11:12:33 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * root.h (scm_root, scm_set_root): Decouple thread support details
+ by introducing the selector SCM_THREAD_LOCAL_DATA and the mutator
+ SCM_SET_THREAD_LOCAL_DATA.
+
+ * print.c (scm_iprlist): Bugfix: Added SCM_ECONSP tests in hare
+ and tortoise scanning loop.
+
+Thu Oct 3 00:04:53 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.in: Rebuild dependencies.
+
+ * libguile.h: #include "libguile/print.h" before "smob.h", since
+ the latter uses the print_state structure.
+
+ * throw.c (scm_ithrow): Use the correct variable when checking to
+ see if a given element of scm_dynwinds is a valid catch.
+
+ * throw.c (scm_ithrow): If scm_dynwinds has invalid list
+ structure, abort; don't just silently ignore the garbage.
+
+ * _scm.h: #include "print.h" here, since it seems to be used just
+ about everywhere.
+ * eval.c, gdbint.c, genio.h, numbers.h, smob.h, srcprop.c,
+ strports.c, unif.h: Don't #include "print.h".
+
+Tue Oct 1 05:15:10 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * feature.h (scm_loc_features): Removed external declaration.
+ (Bug fix suggested by Petr Adamek <adamek@mit.edu>.)
+
+Tue Oct 1 00:00:10 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * feature.c (scm_init_feature): Added threads feature (needs to be
+ initialized here, since features doesn't exist when
+ scm_init_threads is called).
+
+ * libguile.h: Added #include "libguile/../threads/threads.h".
+ (This is a kludge to get thread support working. This should be
+ fixed.)
+
+ * configure.in, acconfig.h: Added flags for thread support.
+
+ * scmsigs.c: Define `signal' to be `pthread_signal' if using
+ mit-pthreads.
+
+ * gc.c (scm_igc): Added SCM_THREAD_CRITICAL_SECTION_START and
+ SCM_THREAD_CRITICAL_SECTION_END. Moved marking of root data to
+ root.c:mark_root.
+
+ * _scm.h: Added conditional #include "threads.h"
+
+ * __scm.h (SCM_ASYNC_TICK): Added call to macro
+ SCM_THREADS_SWITCHING_CODE.
+
+ * init.c (scm_start_stack): Call `scm_make_root' to dynamically
+ allocate the basic dynamic root object.
+ (scm_boot_guile): Added call to scm_init_root.
+
+* * root.c, root.h: Added root smob.
+ (cwdr, scm_call_with_new_root, scm_dynamic_root, scm_app_wdr): New
+ functions: Implements dynamic roots mostly according to spec in
+ SCM manual. Main difference is that the second argument is a
+ throw handler rather than an error "thunk".
+
+ * root.h: Added declaration of scm_init_root.
+
+ * root.c: Added #include "genio.h", #include "smob.h", #include
+ "pairs.h", #include "throw.h", #include "dynwind.h", #include
+ "eval.h"
+ (scm_init_root): Added #include "root.x".
+
+ * throw.c: Added #include "stackchk.h"
+ (scm_catch): Changed SCM_DEFER_INTS --> SCM_REDEFER_INTS and
+ SCM_ALLOW_INTS --> SCM_REALLOW_INTS. This is so that scm_catch
+ can be used in scm_call_with_new_root; Added reenabling of stack
+ checking when catching a throw.
+
+Mon Sep 30 21:48:11 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * list.c, list.h: Use SCM_P instead of CPP hair. Doc fixes.
+
+ * list.c (scm_member, scm_memv, scm_memq): Return #f if a matching
+ element is not found, as per R4RS.
+
+Sat Sep 28 18:13:01 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * list.c: Doc fixes throughout.
+
+Sat Sep 28 02:07:43 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * strings.c, strings.h: (scm_makfrom0str, scm_makefrom0str_opt:
+ declare the char * to be const. Avoids a warning in rgx.c.
+
+ * ports.h: spelling fix.
+
+ * filesys.c (scm_sys_stat, scm_sys,lstat): include file name in
+ error messages.
+
+ * load.c (scm_sys_try_load_path): throw an error if file not found
+ (like it says it in NEWS).
+
+Fri Sep 27 18:27:01 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * symbols.c (scm_intern_obarray_soft): Initialize the new symbol's
+ PROPS slot to '(), not #f; it's an empty alist.
+
+ * throw.h, throw.c: Use SCM_P instead of #if hair.
+
+ Remove special support for uncaught throws; see throw.c for
+ rationale.
+ * throw.c (uncaught_throw): New function.
+ (scm_ithrow): Call uncaught_throw if we don't find a throw
+ target; don't mess with scm_bad_throw_vcell.
+ (scm_bad_throw_vcell): Variable deleted.
+ (scm_init_throw): Don't initialize it.
+
+ * throw.c (scm_ithrow): Don't let outer key matches shadow inner
+ #t catches.
+
+Wed Sep 25 04:35:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * numbers.c (scm_istr2int): If the number is short (as most
+ numbers are), just call scm_small_istr2int to deal with it.
+ (scm_small_istr2int): New function, created by un-#ifdefing the
+ non-bignum version of scm_istr2int and renaming it.
+
+Tue Sep 24 06:48:38 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * load.c (scm_sys_try_load): don't check whether value returned
+ by scm_open_file is #f, it won't be. Always return SCM_UNSPECIFIED.
+ Change the Scheme name from %try-load to primitive-load.
+
+ * error.c (scm_error): convert a NULL message to SCM_BOOL_F.
+ Can avoid passing a message, allowing it to be derived in the
+ error handler (e.g., if we want to throw to the key both from
+ Scheme and C).
+
+Mon Sep 23 00:42:15 1996 Mikael Djurfeldt <mdj@kenneth>
+
+* * print.c (scm_iprin1, scm_prin1, scm_iprlist): Circular
+ references now have a new appearance which is more compact and
+ also gives a clue about what the target of the reference is.
+ By setting parameters in the print state, more fancy printing can
+ be achieved. This is used by the (not yet commited) backtrace
+ code.
+
+Sun Sep 22 17:10:06 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * eval.c, numbers.h, unif.h, smob.h, srcprop.c: Added #include
+ "print.h"
+
+ * print.c: Added #include "struct.h". Removed function
+ scm_prlist.
+
+ * print.h: Modified prototypes for scm_iprlist, scm_prin1 and
+ scm_iprin1. Removed prototype for scm_prlist.
+
+ * arbiters.c (prinarb),
+ async.c (print_async),
+ debug.c (prindebugobj, prinmemoized),
+ eval.c (prinprom, prinmacro),
+ filesys.c (scm_fd_print, scm_dir_print),
+ kw.c (print_kw),
+ mallocs.c (prinmalloc),
+ numbers.c, numbers.h (scm_floprint, scm_bigprint),
+ smob.h (scm_smobfuns),
+ srcprop.c (prinsrcprops),
+ throw.c (prinjb),
+ unif.c, unif.h (scm_raprin1, rapr1),
+ variable.c (prin_var): Changed argument `int writing' to
+ `scm_print_state *pstate'.
+
+ * init.c (scm_boot_guile): Moved scm_init_struct upwards so
+ that it will be called before scm_init_print.
+
+ * print.c (scm_prin1): Print states are now allocated when calling
+ scm_prin1 and then passed around to all printing functions as an
+ argument. A cache `print_state_pool' enables reuse of print
+ states.
+ (scm_make_print_state): New function.
+ (scm_iprin1): Adaption to print states.
+ (scm_iprlist): An initial "hare and tortoise" scan brings down
+ time complexity to O (depth * N). (Better time complexity will be
+ achieved when the printing code is completely rewritten.)
+
+Fri Sep 20 22:01:36 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * aclocal.m4 (GUILE_STRUCT_UTIMBUF): Use AC_CACHE_CHECK instead of
+ AC_CACHE_VAL; #define UTIMBUF_NEEDS_POSIX outside AC_CACHE_VAL, so
+ it gets done whether or not the cache variable has a value.
+
+Thu Sep 19 17:06:39 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ Distinguish #f and ().
+ * __scm.h: #undef SICP.
+ * pairs.h (SCM_EOL): Delete this definition, equating it with
+ SCM_BOOL_F.
+ * tags.h (SCM_EOL): Give it a new definition here; I think I found
+ the value it used to have. Doc fixes, too.
+
+Thu Sep 19 15:33:51 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * struct.c (scm_make_struct_layout, init_struct, scm_struct_ref,
+ scm_struct_set_x), struct.h, gc.c (scm_gc_mark): Completed Tom
+ Lord's implementation of structs, allowing for tail arrays as
+ described in the manual. Also fixed some bugs. (Both the interface
+ and the implementation should be improved.)
+
+ * read.c (scm_init_read): Removed #ifdef READER_EXTENSIONS
+
+ * print.c, print.h: Closures now print like #<procedure foo (x)>.
+ People who whish to see the source can do `(print-enable 'source)'.
+ Removed #ifdef DEBUG_EXTENSIONS.
+
+Thu Sep 19 00:00:29 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scsm_sys_stat): don't SIGSEGV if argument is an
+ integer (assuming for now accepting an integer is a good thing).
+
+ * error.c, fports.c: replace use of %S in lgh_error args with %s.
+ %S will be used instead for write'ing arguments.
+
+ * unif.c (scm_transpose_array): change arguments in the SCM_WNA
+ asserts. fix a few other asserts.
+ (scm_aind, scm_enclose_array, scm_array_in_bounds_p,
+ scm_uniform_vector_ref, scm_array_set_x,
+ scm_dimensions_to_unform_array): change args in
+ SCM_WNA SCM_ASSERTS and change scm_wta's to scm_wrong_num_args.
+ strop.c (scm_substring_move_left_x, scm_substring_move_right_x,
+ scm_substring_fill_x): likewise.
+ gsubr.c (scm_gsubr_apply): likewise.
+ eval.c (SCM_APPLY): likewise.
+
+ * eval.c (4 places): replace scm_everr with lgh_error or
+ scm_wrong_num_args.
+
+ * error.c, error.h (scm_wrong_num_args, scm_wrong_type_arg,
+ scm_memory_error): new procedures.
+* scm_everr: deleted. can use scm_wta, dropping first two args.
+ scm_error: convert NULL subr to SCM_BOOL_F.
+
+ * __scm.h: don't define SCM_STACK_OVFLOW, SCM_EXIT, SCM_ARG6, SCM_ARG7,
+ SCM_ARGERR.
+
+ * stackchk.c (scm_report_stack_overflow): use lgh_error instead
+ of scm_wta.
+
+ * error.c, error.h: new error keys: scm_arg_type_key,
+ scm_args_number_key, scm_memory_alloc_key, scm_stack_overflow_key,
+ scm_misc_error_key.
+ scm_wta: reimplement using lgh_error instead of scm_everr.
+
+Wed Sep 18 17:13:35 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * gdbint.c: scm_lread now has one more argument.
+
+ * ports.c, ports.h: Name change: scm_\(line\|column\)_number -->
+ scm_port_\1; Added mutator scm_set_port_filename_x (used when
+ loading source from non-file ports, which, e. g., happens when
+ using the Emacs interface).
+
+ * fports.c (scm_open_file): Don't call scm_makfrom0str on a scheme
+ object.
+
+ * read.c: Added code for recording of positions of source code
+ expressions; New functions: recsexpr, scm_lreadrecparen;
+ _scm_make_srcprops --> scm_make_srcprops
+ (scm_flush_ws): Removed updating of positions counters. This work
+ is already done by scm_gen_getc
+
+ * read.h: Added prototype for scm_lreadrecparen
+
+ * print.c: Added #include "alist.h"
+
+ * eval.c: Added #include "hash.h"
+
+ * eq.c: Added #include "ramap.h"
+
+ * options.c: Documentation fixes.
+
+ * srcprop.c (scm_finish_srcprop): Bugfix: update ptr.
+ (scm_init_srcprop): Adjusted size of initial source-whash. Name
+ changes: tc16_srcprops --> scm_tc16_srcprops, _scm_make_srcprops
+ --> scm_make_srcprops
+
+ * srcprop.h: Name changes: tc16_srcprops --> scm_tc16_srcprops,
+ _scm_make_srcprops --> scm_make_srcprops; Remove one layer of
+ function calls in the definition of the whash access macros.
+
+Tue Sep 17 11:33:16 1996 Lee Iverson <leei@Canada.AI.SRI.COM>
+
+ * init.c (scm_boot_guile): Add level of indirection to
+ scm_boot_guile_1() to ensure that stack base pointer is properly
+ initialized. There was no guarantee that variable i was the
+ highest/lowest variable on stack (i.e. the call frame of
+ scm_boot_guile was not completely protected from gc).
+
+Tue Sep 17 01:40:56 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.h (scm_port_table): put back file_name, it will be used to
+ support debugging. Undo related changes in fports.c, ioext.c,
+ ports.c, gc.c.
+
+Sun Sep 15 03:58:29 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.h (scm_port_table): remove file_name member for now, it seems
+ undesirable.
+ * fports.c (scm_open_file): don't set file_name in PTAB.
+ (prinfport): don't use file_name in PTAB.
+ * ioext.c (scm_sys_duplicate_port): don't set file_name in PTAB.
+ * ports.c (scm_add_to_port_table): don't intialize file_name.
+ (scm_port_file_name): remove for now.
+ * gc.c (scm_gc_mark): don't mark PTAB file_name.
+
+ * fports.h (scm_mkfile): prototype deleted.
+ * fports.c (scm_mkfile): merged into scm_open_file to simplify.
+
+ * debug.c, unif.c: use scm_out_of_range instead of
+ wta for range errors (ASSERT still needs work).
+
+ * error.c, error.h (scm_out_of_range): new procedure.
+
+ * error.c, error.h (scm_out_of_range_key): new key.
+
+ * posix.c (scm_sync): #else was missing.
+
+ * error.c, error.h: append _key to names scm_num_overflow and
+ scm_system_error.
+
+ * __scm.h (SCM_SYSMISSING, SCM_NUM_OVERFLOW): use SCM_BOOL_F instead
+ of consing an empty list.
+ (SCM_SYSERROR etc.): move into error.c, make them procedures instead
+ of macros, saves code and string space.
+ error.c, fports.c, numbers.c, posix.c, ioext.c, filesys.c, socket.c,
+ fdsocket.c, simpos.c: change names of SCM_SYSERROR etc., to
+ lower case. Rename scm_syserror_m to scm_syserror_msg.
+ error.h: prototypes for new procedures.
+
+Sat Sep 14 03:35:41 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * numbers.c: use SCM_NUM_OVERFLOW instead of scm_wta or ASSERT.
+
+ * error.c, error.h: setup scm_num_overflow key.
+
+ * __scm.h: SCM_NUM_OVERFLOW: macro for reporting numerical overflow.
+ Remove definition of SCM_OVSCM_FLOW.
+
+ * fports.c (scm_open_file): use SCM_SYSERROR_M.
+
+ * __scm.h: SCM_SYSERROR_M: new macro for system errors with an
+ explicit message and args.
+
+ * error.c, error.h, __scm.h: change system_error_sym to
+ scm_system_error.
+
+ * error.c (system_error_sym): remove leading %% from the Scheme name
+ "%%system-error".
+
+ * __scm.h (SCM_SYSMISSING): Redefine using lgh_error.
+
+Fri Sep 13 12:58:08 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * __scm.h, chars.c, debug.c, eval.c, eval.h, extchrs.c, extchrs.h,
+ fdsocket.c, feature.c, mbstrings.c, mbstrings.h, numbers.c,
+ numbers.h, print.c, scmhob.h, simpos.h, symbols.c, symbols.h,
+ tags.h, throw.c, variable.h: Name cleanup. Lots of xxxSCM_yyy
+ renamed. (These were introduced by unsupervised name
+ substitution.)
+
+Fri Sep 13 01:19:08 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+* * print.c: Added code for detection of circular references during
+ printing. (init_ref_stack, grow_ref_stack): New functions. Added
+ a hook for printing of closures (accessible via print options).
+ This leads to a split of calls to scm_iprin1 into two classes:
+ elementary print operations (e. g. the code which prints a smob)
+ still use scm_iprin1 while top level calls (like scm_display) use
+ scm_prin1. scm_prin1 begins by clearing the data structure used
+ to record reference information.
+
+ * print.h: Added declarations of scm_prin1 and scm_prlist.
+
+ * strports.c (scm_strprint_obj): scm_iprin1 --> scm_prin1
+
+ * gscm.c (gscm_portprint_obj): scm_iprin1 --> scm_prin1
+
+ * gscm.h (gscm_print_obj): scm_iprin1 --> scm_prin1
+
+ * error.c (err_head): scm_iprin1 --> scm_prin1
+
+ * debug.c: Adjusted header comment.
+
+ * tags.h: Typo.
+
+Wed Sep 11 17:55:59 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * strerror.c: Doc fix.
+
+Thu Sep 12 00:00:32 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * gdbint.c (gdb_read): Now possible to run during GC.
+ (unmark_port, remark_port): New functions.
+
+ * symbols.h (SCM_SETLENGTH): Use SCM_SETCAR.
+
+ * read.c (scm_grow_tok_buf): Use scm_vector_set_length_x instead
+ of allocating a new string object. Also, increase size by
+ the factor 2 instead of 1.5.
+
+Wed Sep 11 15:10:38 1996 Petr Adamek <jimb@floss.cyclic.com>
+
+ * __scm.h (SCM_P): Corrected to run under traditional C.
+
+ * _scm.h (SCM_PROC): Extraneous semicolon (outside functions)
+ removed.
+
+ * async.c: Calls to scm_sysintern corrected.
+
+ * async.h (scm_async_clock): Redundant declaration removed.
+
+ * continuations.c (scm_dynthrow): Redundant declaration removed.
+
+ * debug.c (scm_single_step, scm_memoized, scm_lookup_soft):
+ Definition typos corrected.
+
+ * debug.h: Missing declarations of functions in debug.c added
+ (lots).
+
+ * eval.h (scm_eval_args, scm_deval_args, scm_m_undefine):
+ Missing declarations to functions in eval.c added.
+
+ * filesys.c: Possibly uninitialized variable rv.
+
+ * gc.h (scm_object_addr, scm_unhash_name): Missing
+ declarations of functions defined in gc.c added.
+
+ * genio.c: Possible typos str_data -> wstr_data. ???
+
+ * genio.c: Possibly unintended shadowing of local variable
+ `int c' (gotos out of scope of inner `c'). ???
+
+ * init.c: Uninitialized `SCM last' may be used.
+
+ * ioext.h: (scm_sys_isatty_p): Typo.
+
+ * list.h (scm_list_head): Missing prototype for function in
+ list.c added.
+
+ * numbers.c (scm_two_doubles): Changed from extern to static
+ (is used only within numbers.c).
+
+ * numbers.h: Repeated declarations removed.
+
+ * ports.h (scm_close_all_ports_except): Declaration for the
+ function defined in ports.c added.
+
+ * posix.h: Missing declarations added.
+
+ * procs.h (scm_make_subr_opt): Missing declaration added.
+
+ * socket.h (scm_sys_gethost): Missing declaration added.
+
+ * socket.h: Redundant declarations removed (they are in fdsocket.h).
+
+ * srcprop.h (scm_set_source_property_x, scm_finish_srcprop):
+ Missing declarations added.
+
+ * stime.h (scm_get_internal_real_time): Repeated declarations removed.
+
+ * struct.c: Uninitialized variable `SCM answer' may be used.
+
+ * unif.c (l2ra): Declaration prototype.
+
+ * unif.c (scm_array_equal_p): Dummy definition removed (it is
+ defined in ramap.c).
+
+ * unif.h (scm_raprin1, scm_istr2bve, scm_array_equal_p):
+ Redundant declarations removed (they are in ramap.h).
+
+ * variable.h (scm_make_udvariable,
+ scm_make_undefined_variable): Declaration corrected to
+ correspond variable.c.
+
+ * vectors.h (scm_vector_move_left_x, scm_vector_move_right_x):
+ Missing declarations added.
+
+Wed Sep 11 14:38:50 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (distclean): Don't forget to delete fd.h.
+
+Tue Sep 10 14:01:46 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * fd.h.in, tags.h: Trivial cleanups.
+
+ * marksweep.c, marksweep.h: Deleted; marksweep.c was empty, and
+ marksweep.h just declared functions from gc.c.
+ * gc.h, libguile.h: Don't #include "marksweep.h".
+ * Makefile.in (libobjs, inner_h_files, c_files, gen_c_files): Omit
+ marksweep.o, marksweep.h, marksweep.c, and marksweep.x. Other
+ dependencies updated.
+
+ * libguile.h: Don't #include "files.h"; it's been deleted.
+
+ * files.c (scm_sys_delete_file): Moved to filesys.c.
+ File is now empty; deleted.
+ * files.h: Deleted.
+ * filesys.c: scm_sys_delete_file is now here. Remove
+ #if's; they seem to rely on remnants of an old portability
+ regimen. If the problems come up again, solve them properly,
+ using autoconf. Specifically: Don't test M_SYSV, and #define
+ remove to be unlink if it's #defined; don't use remove just
+ because HAVE_STDC_HEADERS is #defined.
+ * filesys.h: Add declarations for scm_sys_delete_file.
+ * Makefile.in (libobjs, inner_h_files, c_files, gen_c_files): Omit
+ files.o, files.h, files.c, and files.x.
+ * init.c: Don't #include "files.h", and don't call scm_init_files.
+
+ Use SCM_P instead of PROTO; the latter intrudes on the user's
+ namespace.
+ * params.h: Deleted; definition of SCM_P moved to...
+ * __scm.h: ... here, where it replaces PROTO macro.
+ * libguile.h, smob.h: Don't #include "params.h".
+ * continuations.c, error.h, feature.h, gc.c, gc.h, init.h, load.h,
+ smob.h: Fix prototypes accordingly.
+ * Makefile.in: Update dependencies.
+ (inner_h_files): Remove params.h.
+
+ * gc.c: #include "gc.h"; every module should include its header,
+ to let the compiler cross-check the declarations against the
+ definitions.
+
+ * eq.h, files.h, hashtab.h, load.h, mallocs.h, scmsigs.h,
+ simpos.h: #include "libguile/__scm.h".
+
+Mon Sep 9 20:00:15 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * init.c: Don't forget to #include smob.h and init.h.
+ * Makefile.in: Dependencies updated.
+
+ * smob.h: Use PROTO instead of #if __STDC__.
+
+ * continuations.c (scm_dynthrow): Use PROTO, not SCM_P.
+
+ * __scm.h: Doc fixes.
+
+ * __scm.h, libguile.h: Use "quotes" in the #includes, not
+ <angles>; this allows `make depends' to work properly.
+
+ * libguile.h: #include smob.h and pairs.h before the others; they
+ define typedefs used by other headers.
+
+ C files should #include only the header files they need, not
+ libguile.h (which #includes all the header files); the pointless
+ recompilation was wasting my time.
+ * Makefile.in (all .o dependency lists): Regenerated.
+ * libguile.h: Don't try to get a definition for size_t here...
+ * __scm.h: Do it here.
+ * _scm.h: Since this is the internal libguile header, put things
+ here that all (or a majority) of the libguile files will want.
+ Don't #include <libguile.h> here; that generates dependencies on
+ way too much. Instead, get "__scm.h", "error.h", "pairs.h",
+ "list.h", "gc.h", "gsubr.h", "procs.h", "numbers.h", "symbols.h",
+ "boolean.h", "strings.h", "vectors.h", "root.h", "ports.h", and
+ "async.h".
+ * alist.c: Get "eq.h", "list.h", "alist.h".
+ * append.c: Get "append.h", "list.h".
+ * arbiters.c: Get "arbiters.h", "smob.h".
+ * async.c: Get "async.h", "smob.h", "throw.h", "eval.h".
+ * boolean.c: Get "boolean.h".
+ * chars.c: Get "chars.h".
+ * continuations.c: Get "continuations.h", "dynwind.h", "debug.h",
+ "stackchk.h".
+ * debug.c: Get "debug.h", "feature.h", "read.h", "strports.h",
+ "continuations.h", "alist.h", "srcprop.h", "procprop.h", "smob.h",
+ "genio.h", "throw.h", "eval.h".
+ * dynwind.c: Get "dynwind.h", "alist.h", "eval.h".
+ * eq.c: Get "eq.h", "unif.h", "smob.h", "strorder.h",
+ "stackchk.h".
+ * error.c: Get "error.h", "throw.h", "genio.h", "pairs.h".
+ * eval.c: Get "eval.h", "stackchk.h", "srcprop.h", "debug.h",
+ "hashtab.h", "procprop.h", "markers.h", "smob.h", "throw.h",
+ "continuations.h", "eq.h", "sequences.h", "alist.h", "append.h",
+ "debug.h".
+ * fdsocket.c: Get "fdsocket.h", "unif.h", "filesys.h".
+ * feature.c: Get "feature.h".
+ * files.c: Get "files.h".
+ * filesys.c: Get "filesys.h", "smob.h", "genio.h".
+ * fports.c: Get "fports.h", "markers.h".
+ * gc.c: Get "async.h", "unif.h", "smob.h", "weaks.h",
+ "genio.h", "struct.h", "stackchk.h", "stime.h".
+ * gdbint.c: Get "gdbint.h", "chars.h", "eval.h", "print.h",
+ "read.h", "strports.h", "tag.h".
+ * genio.c: Get "genio.h", "chars.h".
+ * gsubr.c: Get "gsubr.h", "genio.h".
+ * hash.c: Get "hash.h", "chars.h".
+ * hashtab.c: Get "hashtab.h", "eval.h", "hash.h", "alist.h".
+ * init.c: Get everyone who has an scm_init_mumble function:
+ "weaks.h", "vports.h", "version.h", "vectors.h", "variable.h",
+ "unif.h", "throw.h", "tag.h", "symbols.h", "struct.h",
+ "strports.h", "strorder.h", "strop.h", "strings.h", "stime.h",
+ "stackchk.h", "srcprop.h", "socket.h", "simpos.h", "sequences.h",
+ "scmsigs.h", "read.h", "ramap.h", "procs.h", "procprop.h",
+ "print.h", "posix.h", "ports.h", "pairs.h", "options.h",
+ "objprop.h", "numbers.h", "mbstrings.h", "mallocs.h", "load.h",
+ "list.h", "kw.h", "ioext.h", "hashtab.h", "hash.h", "gsubr.h",
+ "gdbint.h", "gc.h", "fports.h", "filesys.h", "files.h",
+ "feature.h", "fdsocket.h", "eval.h", "error.h", "eq.h",
+ "dynwind.h", "debug.h", "continuations.h", "chars.h", "boolean.h",
+ "async.h", "arbiters.h", "append.h", "alist.h".
+ * ioext.c: Get "ioext.h", "fports.h".
+ * kw.c: Get "kw.h", "smob.h", "mbstrings.h", "genio.h".
+ * list.c: Get "list.h", "eq.h".
+ * load.c: Get "load.h", "eval.h", "read.h", "fports.h".
+ * mallocs.c: Get "smob.h", "genio.h".
+ * markers.c: Get "markers.h".
+ * mbstrings.c: Get "mbstrings.h", "read.h", "genio.h", "unif.h",
+ "chars.h".
+ * numbers.c: Get "unif.h", "genio.h".
+ * objprop.c: Get "objprop.h", "weaks.h", "alist.h", "hashtab.h".
+ * options.c: Get "options.h".
+ * ports.c: Get "ports.h", "vports.h", "strports.h", "fports.h",
+ "markers.h", "chars.h", "genio.h".
+ * posix.c: Get "posix.h", "sequences.h", "feature.h", "unif.h",
+ "read.h", "scmsigs.h", "genio.h", "fports.h".
+ * print.c: Get "print.h", "unif.h", "weaks.h", "read.h",
+ "procprop.h", "eval.h", "smob.h", "mbstrings.h", "genio.h",
+ "chars.h".
+ * procprop.c: Get "procprop.h", "eval.h", "alist.h".
+ * procs.c: Get "procs.h".
+ * ramap.c: Get "ramap.h", "feature.h", "eval.h", "eq.h",
+ "chars.h", "smob.h", "unif.h".
+ * read.c: Get "alist.h", "kw.h", "mbstrings.h", "unif.h",
+ "eval.h", "genio.h", "chars.h".
+ * root.c: Get "root.h", "stackchk.h".
+ * scmsigs.c: Get "scmsigs.h".
+ * sequences.c: Get "sequences.h".
+ * simpos.c: Get "simpos.h", "scmsigs.h".
+ * smob.c: Get "smob.h".
+ * socket.c: Get "socket.h", "feature.h".
+ * srcprop.c: Get "srcprop.h", "weaks.h", "hashtab.h", "debug.h",
+ "alist.h", "smob.h".
+ * stackchk.c: Get "stackchk.h", "genio.h".
+ * stime.c: Get "stime.h"."libguile/continuations.h".
+ * strings.c: Get "strings.h", "chars.h".
+ * strop.c: Get "strop.h", "chars.h".
+ * strorder.c: Get "strorder.h", "chars.h".
+ * strports.c: Get "strports.h", "print.h", "eval.h", "unif.h".
+ * struct.c: Get "struct.h", "chars.h".
+ * symbols.c: Get "symbols.h", "mbstrings.h", "alist.h",
+ "variable.h", "eval.h", "chars.h".
+ * tag.c: Get "tag.h", "struct.h", "chars.h".
+ * throw.c: Get "throw.h", "continuations.h", "debug.h",
+ "dynwind.h", "eval.h", "alist.h", "smob.h", "genio.h".
+ * unif.c: Get "unif.h", "feature.h", "strop.h", "sequences.h",
+ "smob.h", "genio.h", "eval.h", "chars.h".
+ * variable.c: Get "variable.h", "smob.h", "genio.h".
+ * vectors.c: Get "vectors.h", "eq.h".
+ * version.c: Get "version.h".
+ * vports.c: Get "vports.h", "fports.h", "chars.h", "eval.h".
+ * weaks.c: Get "weaks.h".
+
+ * stackchk.h: #include "libguile/debug.h",
+
+ * print.h, read.h: #include "options.h", since everyone who uses
+ either of these files will need that.
+
+ * smob.h: #include "ports.h", "genio.h", and "print.h", since
+ anyone who uses this file will need them to define the smob
+ printing functions. Also, get markers.h, since people will need
+ to #define the mark functions.
+
+ * smob.h (scm_ptobfuns, SCM_PTOBNUM): Definitions moved...
+ * ports.h: ... to here.
+
+ * ports.h (scm_port_table_size): Explicitly give type as 'int';
+ don't rely on archaic C default type rules.
+
+ * fports.h: #include "libguile/ports.h", since you need that in
+ order to parse this.
+
+ * genio.h: #include "libguile/print.h", because you need that to
+ parse this; don't bother #including "ports.h", since print.h gets
+ that.
+
+ * error.h: Don't #include "pairs.h"; _scm.h will do that now.
+
+ * eval.h (scm_top_level_lookup_thunk_var): Remove declaration for
+ this; it's now a reference to an element of *scm_root.
+
+ * debug.h: Don't #include "options.h"; the compiler won't be able
+ to find that once the headers are installed; instead, #include
+ "libguile/options.h".
+ * gc.h: Same, with marksweep.h.
+ * mbstrings.h: Same, with symbols.h.
+ * scmhob.h: Same, with _scm.h.
+ * smob.h: Same, with params.h.
+
+ * Makefile.in (depends): Don't nuke scmconfig.h and the generated
+ C files; there's no need for this, and it forces recompilations
+ unnecessarily.
+
+Sat Sep 7 06:57:23 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * error.c (scm_error): declare scm_error_callback.
+
+ * error.h: prototype for scm_error_callback.
+
+ * __scm.h: define lgh_error.
+ (SCM_SYSERROR): redefine using lgh_error.
+
+Thu Sep 5 22:40:06 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * error.c (scm_error): new procedure.
+
+ * error.h: prototype for scm_error.
+
+ * Makefile.in (install): install scmconfig.h from the current
+ directory, not $(srcdir).
+
+Thu Sep 5 11:38:07 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * alist.h, append.h, arbiters.h, async.h, boolean.h, chars.h,
+ continuations.h, debug.h, dynwind.h, error.h, eval.h, fdsocket.h,
+ feature.h, filesys.h, fports.h, gc.h, gdbint.h, genio.h, gsubr.h,
+ hash.h, init.h, ioext.h, kw.h, list.h, markers.h, marksweep.h,
+ mbstrings.h, numbers.h, objprop.h, options.h, pairs.h, ports.h,
+ posix.h, print.h, procprop.h, procs.h, ramap.h, read.h, root.h,
+ sequences.h, smob.h, socket.h, srcprop.h, stackchk.h, stime.h,
+ strings.h, strop.h, strorder.h, strports.h, struct.h, symbols.h,
+ tag.h, throw.h, unif.h, variable.h, vectors.h, version.h,
+ vports.h, weaks.h: #include "libguile/__scm.h", not
+ <libguile/__scm.h>. This allows 'gcc -MM' to determine which
+ dependencies are within libguile properly.
+
+Thu Sep 5 11:38:07 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (.c.x): Simplify; there's no need to run this rule
+ when scmconfig.h doesn't exist.
+
+ * load.c (scm_sys_try_load): Correct spelling.
+
+ * feature.c (scm_loc_features): Make this static.
+
+ * Makefile.in (libpath.h): Omit trailing slash from path. We
+ shouldn't require it of users, so why put it here?
+
+ Move code to initialize and search %load-path from ice-9 to C
+ code, so we can use the load-path to find the ice-9 boot code;
+ this makes it easier to run Guile without installing it. See
+ corresponding changes in guile/Makefile.in.
+ * feature.c: Move stuff concerned with the load path to load.c.
+ (scm_compiled_library_path): Deleted.
+ Don't #include libpath.h here.
+ * feature.h: Don't mention scm_compiled_library_path.
+ * load.c: #include "libpath.h" here, as well as <sys/types.h>,
+ <sys/stat.h>, and <unistd.h> (if present).
+ (R_OK): #define if the system hasn't deigned to.
+ (scm_loc_load_path): New variable.
+ (scm_init_load_path, scm_sys_search_load_path,
+ scm_sys_try_load_path): New functions.
+ (scm_init_load): Initialize scm_loc_load_path to point to the
+ value cell of the Scheme %load-path variable.
+ * load.h: Add declarations for scm_sys_search_load_path,
+ scm_sys_try_load_path.
+ * init.c: Call scm_init_load_path.
+ * Makefile.in (feature.o, load.o): Dependencies updated.
+
+ * load.c, load.h: Rewrite using PROTO macro.
+
+Thu Sep 5 01:54:33 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * gc.c (scm_cellp): New function: C predicate to determine if an
+ SCM value can be regarded as a pointer to a cell on the heap.
+
+ * gc.h: Added declaration of scm_cellp.
+
+ * gdb_interface.h: New file: The GDB interface header from the GDB
+ distribution.
+
+ * gdbint.c: New file: GDB interface.
+
+ * gdbint.h: New file: GDB interface.
+
+ * libguile.h: Added #include <libguile/gdbint.h>.
+
+ * init.c (scm_boot_guile): Added scm_init_gdbint.
+
+ * Makefile.in: Added gdb_interface.h, gdbint.[hc].
+ Added -I.. to INCLUDE_CFLAGS (otherwise the include files won't be
+ found if object files and source are kept separate).
+
+Wed Sep 4 14:35:02 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * feature.h, feature.c: Use PROTO macro, instead of #if __STDC__.
+
+Wed Sep 4 01:30:47 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * configure.in: Don't substitute the values of TCL_SRC_DIR and
+ TK_SRC_DIR; they're not relevant any more.
+
+ * Makefile.in (CC): Don't list -Wall here; it's a GCC-specific flag.
+ * configure.in: Instead, put it in CFLAGS here, iff we're using GCC.
+
+Wed Sep 4 00:55:49 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * PLUGIN/guile.config (xtra_cflags): Include .. in the header
+ search path, so we can find the <libguile/MUMBLE.h> headers.
+
+ * Makefile.in (ancillary): List aclocal.m4, for 'make dist'.
+
+ * Makefile.in (ALL_CFLAGS): Don't mention CFLAGS here; it's
+ implicit in the .c.o rule.
+ (.c.x): Don't mention ALL_CFLAGS here; its value is included in
+ $(CC) already.
+
+ Put the library path in a header file, instead of passing it on
+ the command line in every compilation.
+ * Makefile.in (libpath.h): New target.
+ (feature.o): Depend on libpath.h.
+ (clean): Delete libpath.h.
+ (ALL_CFLAGS): Don't use -DLIBRARY_PATH here. Instead ...
+ * feature.c: ... #include "libpath.h" here.
+ * .cvsignore: Ignore libpath.h.
+
+* Don't install the unwashed masses of Guile header files in the
+ main #include path; put most of them in a subdirectory called
+ 'libguile'. This avoids naming conflicts between Guile header
+ files and system header files (of which there were a few).
+ * Makefile.in (pkgincludedir): Deleted.
+ (innerincludedir): New variable; this and $(includedir) are enough.
+ (INCLUDE_CFLAGS): Search for headers in "-I$(srcdir)/..".
+ (installed_h_files): Divide this up. Now this variable lists
+ those header files which should go into $(includedir) (i.e. appear
+ directly in the #include path), and ...
+ (inner_h_files): ... this new variable says which files appear in
+ a subdirectory, and are referred to as <libguile/mumble.h>.
+ (h_files): List them both.
+ (install): Create innerincludedir, not pkgincludedir. Put
+ the installed_h_files and inner_h_files in their proper places.
+ (uninstall): Corresponding changes.
+ * alist.h, append.h, arbiters.h, async.h, boolean.h, chars.h,
+ continuations.h, debug.h, dynwind.h, error.h, eval.h, fdsocket.h,
+ feature.h, fports.h, gc.h, genio.h, gsubr.h, hash.h, init.h,
+ ioext.h, kw.h, libguile.h, list.h, markers.h, marksweep.h,
+ mbstrings.h, numbers.h, options.h, pairs.h, ports.h, posix.h,
+ print.h, procprop.h, procs.h, ramap.h, read.h, root.h,
+ sequences.h, smob.h, socket.h, srcprop.h, stackchk.h, stime.h,
+ strings.h, strop.h, strorder.h, strports.h, struct.h, symbols.h,
+ tag.h, throw.h, unif.h, variable.h, vectors.h, version.h,
+ vports.h, weaks.h: Find __scm.h in its new location.
+ * __scm.h: Find scmconfig.h and tags.h in their new locations
+ (they're both "inner" files).
+
+Tue Sep 3 20:27:35 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (.c.x): Remove duplicate use of $(ALL_CFLAGS).
+
+Tue Sep 3 19:53:00 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * posix.c: Doc fixes.
+
+Mon Sep 2 15:22:40 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * socket.c: Don't include a prototype for inet_aton; just use a
+ K&R style declaration, to avoid warnings but minimize the chance
+ of conflicts with the system.
+
+ On NextStep, <utime.h> doesn't define struct utime, unless we
+ #define _POSIX_SOURCE before #including it.
+ * aclocal.m4 (GUILE_STRUCT_UTIMBUF): New test.
+ * acconfig.h: New comment text for above CPP symbol.
+ * configure.in: Call it.
+ * posix.c: #define _POSIX_SOURCE if it seems necessary.
+
+ * configure.in (AC_CHECK_HEADERS): Include sys/utime.h and utime.h
+ in the list.
+ * posix.c: Check HAVE_SYS_UTIME_H and HAVE_UTIME_H, instead of
+ testing for __EMX__.
+
+ * posix.c: #include <libc.h>, if it exists.
+
+ * posix.c: Cast the return result to GETGROUPS_T, not gid_t; we
+ don't even know if the latter exists.
+
+ * posix.c (s_sys_setpgid, s_sys_setsid, s_sys_ctermid,
+ s_sys_tcgetpgrp, s_sys_tcsetpgrp): Renamed from s_setpgid,
+ s_setsid, s_ctermid, s_tcgetpgrp, s_tcsetpgrp, for consistency.
+
+ * posix.c (R_OK, W_OK, X_OK, F_OK): #define these if the system's
+ header files don't.
+ (scm_init_posix): Use them when initializing the Scheme constants
+ of the same name.
+
+Fri Aug 30 16:01:30 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (libdir, includedir, bindir): Use the
+ autoconf-supplied values, instead of deriving them ourselves.
+ (pkgincludedir, datadir, pkgdatadir): New variables.
+ (install, uninstall): Put the header files in a special
+ subdirectory, not in the main search path.
+
+ * Makefile.in (ALL_CFLAGS): Provide the proper value for
+ LIBRARY_PATH --- use $(pkgdatadir) instead of $(libdir).
+
+ * Makefile.in (IMPLPATH): Deleted; never used.
+
+ * Makefile.in (TCL_SRC_DIR, TK_SRC_DIR): Deleted; we don't depend
+ on the Tcl/Tk source any more.
+ (INCLUDE_CFLAGS): Remove references to the above.
+
+ * Makefile.in (version.o): Corrected dependencies.
+
+Thu Aug 29 23:06:19 1996 Thomas Morgan <tmorgan@gnu.ai.mit.edu>
+
+ * libguile.h: #include "version.h"
+
+ * init.c (scm_boot_guile): Call scm_init_version.
+ * gscm.c (gscm_run_scm): Call scm_init_version.
+
+ * configure.in (GUILE_MAJOR_VERSION, GUILE_MINOR_VERSION,
+ GUILE_VERSION): AC_DEFINE these.
+ (acconfig.h): #undef the above symbols.
+
+ * Makefile.in (libobjs): Add version.o.
+ (installed_h_files): Add version.h.
+ (c_files): Add version.c.
+ (gen_c_files): Add version.x.
+ (version.o): New rule.
+ (alist.o, append.o, appinit.o, arbiters.o, async.o, boolean.o,
+ chars.o, continuations.o, dynwind.o, eq.o, error.o, eval.o,
+ fdsocket.o, feature.o, files.o, filesys.o, fports.o, gc.o,
+ genio.o, gsubr.o, hash.o, hashtab.o, init.o, kw.o, list.o, load.o,
+ mallocs.o, markers.o, marksweep.o, mbstrings.o, numbers.o,
+ objprop.o, pairs.o, ports.o, posix.o, print.o, procprop.o,
+ procs.o, ramap.o, read.o, root.o, scmsigs.o, sequences.o,
+ simpos.o, smob.o, socket.o, stackchk.o, stime.o, strings.o,
+ strop.o, strorder.o, strports.o, struct.o, symbols.o, tag.o,
+ throw.o, unif.o, variable.o, vectors.o, version.o, vports.o,
+ weaks.o): Add version.h to dependency lists.
+ (markers.o): Remove duplicate rule.
+
+ * version.h: New file.
+
+ * version.c: New file.
+
+Thu Aug 29 15:21:39 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * symbols.c (scm_strhash): scm_downcase is now a function, not an
+ array; use it appropriately. Since GCC is quite happy to
+ subscript functions, it never warned us about this; we should use
+ -Wpointer-arith in the future. I guess we never tested
+ case-insensitivity.
+
+Wed Aug 28 18:52:22 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * socket.c: Doc and copyright fixes.
+
+Sat Aug 24 05:29:19 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * debug.c: Fixed and improved gdb support.
+
+Fri Aug 23 18:00:16 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * socket.c: Added declaration of inet_aton to avoid compiler
+ warning. (Hope this solution is correct.)
+
+ * stime.c: Added declaration of ftime. (This is missing in
+ Solaris 2 headers.)
+
+Fri Aug 23 02:03:32 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * configure, scmconfig.h.in: Updated, using autoconf and autoheader.
+
+ * Makefile.in (c_files): add strerror.c.
+
+ * strerror.c: new file from Emacs' sysdep.c.
+ maybe configure should also check for sys_errlist.
+
+ * configure.in (AC_REPLACE_FUNCS): add strerror.
+
+Fri Aug 23 03:02:46 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * debug.c (scm_init_debug): Added initialization for
+ scm_evaluator_traps.
+
+ * debug.h, debug.c: Various name changes.
+ (Mostly prefixing with SCM_.) Renamed "debug-options" -->
+ "debug-options-interface". See commentary in options.c.
+
+ * options.h, options.c: Options now have documentation strings.
+ Also added a long explanatory commentary.
+
+ * eval.c, print.h, print.c, read.h, read.c: Modifications to
+ run-time options.
+
+ * gscm.c, init.c, root.c, throw.c: Bug fixes:
+ last_debug_info_frame is now updated in all cases.
+
+ * __scm.h, stackchk.h, stackchk.c: Guile now performs stack
+ checking.
+
+Thu Aug 22 17:34:17 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * __scm.h: SCM_STACK_LIMIT removed (now a run-time option).
+ Added option STACK_CHECKING.
+
+Tue Aug 20 18:48:40 1996 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * Makefile.in: Added {debug,options,srcprop}.{h,c}
+
+ * __scm.h: Removed symbols for debugging support.
+
+ * acconfig.h: Added symbols for debugging support.
+
+* * configure.in: Added user option for debugging support.
+ --enable-debug will include the debugging code into libguile.a.
+
+ * continuations.c (scm_make_cont): Enlarged the #if 0 around
+ scm_relocate_chunk_to_heap.
+
+* * debug.c: New file: low-level debugging support. It also
+ includes support for debugging with gdb. (The extensions to gdb
+ are written by Per Bothner at Cygnus.)
+
+ * debug.h: New file: low-level debugging support.
+
+* * eval.c: scm_m_set and SCM_IM_SET no longer supports multiple
+ argument pairs. Extensive modifications to the debugging
+ evaluator. Added "SECTION:" commentaries to clarify what happens
+ when, during double compilation. Renamed EVALIMP --> EVALIM.
+ Renamed EVAL --> XEVAL. Removed function evalcar. Defined
+ evalcar to scm_eval_car. Added explanation of "EVAL" symbols to
+ the beginning of the file. New procedure: scm_unmemocopy.
+ Added some global state variables needed by the debugging
+ evaluator: scm_ceval_ptr, last_debug_info_frame, debug_mode,
+ check_entry, check_apply, check_exit, debug_options and
+ evaluator_traps. New acro: undefine.
+
+ * eval.h: Renamed EVAL --> XEVAL.
+
+ * gc.c (scm_init_storage): Renamed scm_make_weak_hash_table
+ --> scm_make_weak_key_hash_table.
+
+ * init.c (scm_restart_stack, scm_boot_guile): Added initialization
+ of SCM_DFRAME. Added calls to scm_init_{debug,options,srcprop}.
+
+ * libguile.h: Conditionally include debug.h
+
+* * objprop.c (scm_object_properties, scm_set_object_properties_x):
+ scm_object_properties shouldn't return handle. `handle' now gets
+ initialized in scm_set_object_properties_x. scm_object_properties
+ doesn't any longer create an entry in scm_object_whash.
+
+* * options.c: New file: handling of run time options.
+
+ * options.h: New file: handling of run time options.
+
+ * posix.c (scm_getpgrp): Cast pointer to getpgrp.
+
+* * print.c: New procedure: scm_print_options
+
+ * print.h: Defines for print options.
+
+* * read.c: New procedure: scm_read_options
+
+ * read.h: Defines for reader options.
+
+ * root.h: Added scm_source_whash among scm_sys_protects.
+
+* * srcprop.c: New file: source properties.
+
+ * srcprop.h: New file: source properties.
+
+ * throw.c (jbsmob): Jump buffers are now correctly allocated.
+ (Bug found by A. Green.)
+
+* * weak.c: Renamed scm_weak_hash_table --> scm_weak_key_hash_table.
+
+ * weak.h: Renamed scm_weak_hash_table --> scm_weak_key_hash_table.
+
+Thu Aug 15 02:05:14 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * libguile.h: #include "objprop.h"; I guess this was forgotten.
+
+ * init.c (scm_boot_guile): Don't call scm_init_rgx; it's a plugin,
+ and should be called by the final client.
+
+Wed Aug 14 21:41:37 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * gc.h: Use the PROTO macro when declaring functions.
+ * gc.c: Use the PROTO macro when declaring static functions.
+ Remove the CPP hair around function definitions.
+
+ * gc.c (scm_init_storage): Initialize scm_asyncs.
+
+ * libguile.h: #include "__scm.h" before testing the STDC_HEADERS
+ preprocessor symbol; "__scm.h" is where it might get #defined.
+ * __scm.h: Similar: #include <scmconfig.h> before testing
+ HAVE_LIMITS_H.
+
+ * __scm.h: It's HAVE_LIMITS_H, not HAVE_LIMITSH.
+
+Fri Aug 9 11:09:28 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+* * init.c (scm_boot_guile): Add init_func argument; call
+ (*init_func) instead of calling scm_appinit; it's ucky to
+ hard-code names for the user's procedures.
+ * init.h (scm_boot_guile): Adjust declaration.
+
+ * __scm.h (PROTO): New macro, for declaring functions with
+ prototypes.
+
+ * init.h (scm_start_stack, scm_restart_stack): Use PROTO;
+ eliminate all the __STDC__ conditionals.
+ (scm_boot_guile): Add declaration.
+ * init.c (scm_start_stack, scm_restart_stack, scm_boot_guile):
+ Remove __STDC__ conditionals around function definitions; the
+ declarations in init.h will provide the same information, more
+ usefully.
+
+ * __scm.h (SCM_SYSMISSING): When we don't have ENOSYS, don't
+ complain about it in the error message; the error message is
+ adequate without that note, and there's nothing the user can do
+ about it.
+
+Wed Aug 7 14:14:46 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.in (ancillary): Drop def.sed.
+
+ * posix.c (scm_init_posix): Use numeric values, rather than
+ CPP symbols, when defining the scheme values R_OK, W_OK, X_OK, and
+ F_OK. The symbols aren't available on some systems, and I'm
+ pretty sure their values are fixed by common widespread practice.
+ * ioext.c (scm_init_ioext): Code here defined them too; remove it.
+
+ More functions unavailable on some systems.
+ * configure.in (AC_CHECK_FUNCS): Add ctermid, setpgid, setsid,
+ tcgetpgrp, tcsetpgrp, and waitpid to the list of functions to
+ check for.
+ * configure, scmconfig.h.in: Updated, using autoconf and autoheader.
+ * posix.c (scm_sys_ctermid, scm_sys_setpgid, scm_sys_setsid,
+ scm_sys_tcgetpgrp, scm_sys_tcsetpgrp, scm_sys_waitpid): Put the
+ bodies of these functions in "#ifdef HAVE_MUMBLE" clauses, with a
+ stub that signals an error as the #else.
+
+ * Makefile.in (ancillary): Drop acconfig-1.5.h; add acconfig.h.
+
+Wed Aug 7 06:28:42 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * Fixes motivated by Petr Adamek <adamek@mit.edu>:
+
+ * unif.c: include ramap.h.
+
+ * read.c (endif): case_insensative_p renamed case_insensitive_p.
+
+ * ramap.h: rename scm_array_copy prototypes to scm_array_copy_x.
+
+ * ports.c: include sys/ioctl.h.
+
+ * scmconfig.h.in: add HAVE_SYS_IOCTL_H.
+
+ * configure.in: check for sys/ioctl.h.
+
+ * ports.c: include <malloc.h> not "malloc.h".
+
+ * mallocs.c: include <malloc.h> not "malloc.h", likewise for unistd.h.
+
+ * fports.c: remove ttyname and tmpnam declarations.
+
+ * posix.c: fewer ttyname declarations.
+
+ * fports.c: include <string.h> not "string.h".
+
+ * init.c, ioext.c: include string.h and unistd.h.
+
+ * gc.c: include <malloc.h> not "malloc.h", likewise for unistd.h.
+
+ * async.c, strings.h, strports.c, struct.c, symbols.c, feature.c,
+ genio.c, simpos.c, vports.c: include string.h.
+
+ * socket.c, fdsocket.c: include string.h only if HAVE_STRING_H.
+
+ * fdsocket.c (getsockopt, setsockopt): change type of optlen from
+ scm_sizet to int.
+ (scm_addr_buffer_size): change type from scm_sizet to int.
+ (accept, getsockname, getpeername, recvfrom): change type of tmp_size
+ from scm_sizet to int.
+
+ * error.c: include unistd.h.
+
+ * __scm.h: (SCM_SYSMISSING): another version in case ENOSYS isn't
+ defined.
+
+ * Makefile.in: remove references to .hd, .cd suffix and __scm.hd.
+
+ * __scm.hd, def.sed: deleted.
+
+Tue Aug 6 14:49:08 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ Changes for NeXT, suggested by Robert Brown.
+ * configure.in: Call AC_TYPE_MODE_T.
+ (AC_CHECK_HEADERS): Add libc.h, to get more prototypes on the
+ NeXT. Put header file list in alphabetical order.
+ * configure, scmconfig.h.in: Regenerated.
+ * filesys.c [HAVE_LIBC_H]: #include <libc.h>.
+
+ * filesys.c [HAVE_STRING_H]: #include <string.h>, to get prototype
+ for strerror.
+
+ * acconfig.h: New file, providing documentation for the CPP
+ symbols defined in configure.in
+ * acconfig-1.5.h: Removed; superceded by the above.
+
+Sat Aug 3 01:27:14 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c (scm_sys_fdopen): fix the port-table assignment.
+
+* * fports.c (scm_open_file): don't return #f, throw error.
+
+* * ioext.c (fileno): renamed from %fileno.
+ (soft-fileno): deleted.
+
+ * ports.c (scm_port_revealed): don't need to check for -1 from
+ scm_revealed_count.
+ (scm_set_port_revealed_x): return unspecified, not #f.
+
+* * ioext.c (primitive-move->fdes): return #t or #f, not 1 or 0.
+
+ * fdsocket.c: getsockopt, setsockopt: use HAVE_STRUCT_LINGER.
+
+ * scmconfig.h.in: add HAVE_STRUCT_LINGER.
+
+ * configure.in: check for struct linger, set HAVE_STRUCT_LINGER.
+
+Thu Aug 1 02:58:39 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * filesys.c, posix.c: #include <sys/types.h> before <sys/stat.h>.
+ This is necessary on Ultrix, and doesn't hurt portability.
+
+ * Makefile.in (dist-dir): New target, implementing a new dist system.
+ (installed_h_files): Put in alphabetical order.
+ Remove duplicate entries for markers.h and unif.h.
+ (c_files): Remove duplicate entries for markers.c.
+ (ancillary): Renamed from anillery; all uses changed. Remove
+ PLUGIN; it's a directory, and needs special treatment in dist-dir.
+ Remove all the ../doc/* files; doc/Makefile.in handles that.
+
+ * Makefile.in (libobjs): Remove duplicate entry for markers.o.
+
+ * Makefile.in (.c.x): Compensate for Ultrix's broken Bourne shell:
+ every if must have an else, or else the whole command has a
+ non-zero exit code whenever the if's condition is false.
+
+Thu Aug 1 08:22:24 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.c: include string.h.
+
+Wed Jul 31 23:43:05 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+* * numbers.c: rename %expt -> $expt, %atan2 -> $atan2, as it must
+ have been once.
+
+* * posix.c, ioext.c, socket.c, fdsocket.c, files.c, filesys.c, simpos.c:
+ Remove leading % from scheme names.
+ Do not return error values, call SCM_SYSERROR or similar.
+
+ * __scm.h (SCM_SYSERROR, SCM_SYSMISSING): new macros.
+
Wed Jun 12 00:28:31 1996 Tom Lord <lord@beehive>
* struct.c (scm_init_struct): new file.
@@ -458,9 +1835,9 @@ Sat Jan 20 23:21:37 1996 Tom Lord <lord@beehive>
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.
+ * 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.
@@ -471,14 +1848,12 @@ Wed Dec 6 02:40:49 1995 Tom Lord <lord@beehive>
* 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.
+ * 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.
-
-
+ Changed the type of SCM_ICHR.
Tue May 16 17:49:58 1995 Mikael Djurfeldt <mdj@sanscalc.nada.kth.se>
diff --git a/libguile/Makefile.in b/libguile/Makefile.in
index d1ed25c4f..dae40ee9e 100644
--- a/libguile/Makefile.in
+++ b/libguile/Makefile.in
@@ -35,14 +35,18 @@ prefix = @prefix@
exec_prefix = @exec_prefix@
# Directory in which to install init files &c
-libdir = $(exec_prefix)/lib
+libdir = @libdir@
-# Directory to search by default for included makefiles.
-includedir = $(prefix)/include
+# Directory for installed #include files for all packages
+includedir = @includedir@
+innerincludedir = $(includedir)/libguile
# Directory to install `guile' in.
-bindir = $(exec_prefix)/bin
+bindir = @bindir@
+# Directories for read-only architecture-independent files.
+datadir=@datadir@
+pkgdatadir=$(datadir)/guile
INSTALL = $(srcdir)/../install-sh -c
INSTALL_DATA = $(INSTALL) -m 644
@@ -51,20 +55,16 @@ INSTALL_DATA = $(INSTALL) -m 644
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
+X11_INCLUDES=@XINCLUDES@
+XFLAGS=@X_CFLAGS@
+CFLAGS=@CFLAGS@
+# Check for headers in $(srcdir)/.., so that #include
+# <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
+# building.
+INCLUDE_CFLAGS=-I. -I.. -I$(srcdir)/.. -I$(srcdir)
+ALL_CFLAGS=$(X_CFLAGS) $(INCLUDE_CFLAGS) $(X11_INCLUDES) @DEFS@
+CC=@CC@ $(ALL_CFLAGS)
# CC used as a front end for ld
LDFLAGS = @LDFLAGS@
@@ -93,10 +93,10 @@ libobjs= alist.o \
extchrs.o \
fdsocket.o \
feature.o \
- files.o \
filesys.o \
fports.o \
gc.o \
+ gdbint.o \
genio.o \
gsubr.o \
hash.o \
@@ -108,11 +108,10 @@ libobjs= alist.o \
load.o \
mallocs.o \
markers.o \
- markers.o \
- marksweep.o \
mbstrings.o \
numbers.o \
objprop.o \
+ options.o \
pairs.o \
ports.o \
posix.o \
@@ -140,14 +139,20 @@ libobjs= alist.o \
unif.o \
variable.o \
vectors.o \
+ version.o \
vports.o \
weaks.o \
$(extras)
-uninstalled_h_files= _scm.h __scm.hd
+# These are headers used only by the internal guile sources.
+uninstalled_h_files= _scm.h
+
+# These are headers visible as <mumble.h>.
+installed_h_files = libguile.h
-installed_h_files= __scm.h \
+# These are headers visible as <libguile/mumble.h>.
+inner_h_files= __scm.h \
alist.h \
append.h \
arbiters.h \
@@ -155,6 +160,7 @@ installed_h_files= __scm.h \
boolean.h \
chars.h \
continuations.h \
+ debug.h \
dynwind.h \
eq.h \
error.h \
@@ -162,10 +168,11 @@ installed_h_files= __scm.h \
extchrs.h \
fdsocket.h \
feature.h \
- fports.h \
- files.h \
filesys.h \
+ fports.h \
gc.h \
+ gdb_interface.h \
+ gdbint.h \
genio.h \
gsubr.h \
hash.h \
@@ -175,49 +182,47 @@ installed_h_files= __scm.h \
kw.h \
list.h \
load.h \
- libguile.h \
mallocs.h \
markers.h \
- marksweep.h \
- markers.h \
mbstrings.h \
numbers.h \
objprop.h \
+ options.h \
pairs.h \
ports.h \
posix.h \
- params.h \
print.h \
- procs.h \
procprop.h \
+ procs.h \
ramap.h \
read.h \
root.h \
+ scmhob.h \
scmsigs.h \
sequences.h \
simpos.h \
smob.h \
socket.h \
+ srcprop.h \
stackchk.h \
+ stime.h \
+ strings.h \
+ strop.h \
+ strorder.h \
strports.h \
struct.h \
symbols.h \
tag.h \
- stime.h \
tags.h \
+ throw.h \
+ unif.h \
variable.h \
vectors.h \
+ version.h \
vports.h \
- weaks.h \
- unif.h \
- scmhob.h \
- strings.h \
- strop.h \
- strorder.h \
- throw.h \
- unif.h
+ weaks.h
-h_files=$(uninstalled_h_files) $(installed_h_files)
+h_files=$(uninstalled_h_files) $(installed_h_files) $(inner_h_files)
c_files= alist.c \
append.c \
@@ -227,6 +232,7 @@ c_files= alist.c \
boolean.c \
chars.c \
continuations.c \
+ debug.c \
dynwind.c \
eq.c \
error.c \
@@ -234,10 +240,10 @@ c_files= alist.c \
extchrs.c \
fdsocket.c \
feature.c \
- files.c \
filesys.c \
fports.c \
gc.c \
+ gdbint.c \
genio.c \
gsubr.c \
hash.c \
@@ -250,11 +256,10 @@ c_files= alist.c \
load.c \
mallocs.c \
markers.c \
- markers.c \
- marksweep.c \
mbstrings.c \
numbers.c \
objprop.c \
+ options.c \
pairs.c \
ports.c \
posix.c \
@@ -269,8 +274,10 @@ c_files= alist.c \
simpos.c \
smob.c \
socket.c \
+ srcprop.c \
stackchk.c \
stime.c \
+ strerror.c \
strings.c \
strop.c \
strorder.c \
@@ -282,6 +289,7 @@ c_files= alist.c \
unif.c \
variable.c \
vectors.c \
+ version.c \
vports.c \
weaks.c
@@ -292,6 +300,7 @@ gen_c_files= alist.x \
boolean.x \
chars.x \
continuations.x \
+ debug.x \
dynwind.x \
eq.x \
error.x \
@@ -299,7 +308,6 @@ gen_c_files= alist.x \
extchrs.x \
fdsocket.x \
feature.x \
- files.x \
filesys.x \
fports.x \
gc.x \
@@ -314,10 +322,10 @@ gen_c_files= alist.x \
load.x \
mallocs.x \
markers.x \
- marksweep.x \
mbstrings.x \
numbers.x \
objprop.x \
+ options.x \
pairs.x \
ports.x \
posix.x \
@@ -332,6 +340,7 @@ gen_c_files= alist.x \
simpos.x \
smob.x \
socket.x \
+ srcprop.x \
stackchk.x \
stime.x \
strings.x \
@@ -345,75 +354,56 @@ gen_c_files= alist.x \
unif.x \
variable.x \
vectors.x \
+ version.x \
vports.x \
weaks.x
-ancillery = gscm.c \
+ancillary = gscm.c \
gscm.h \
COPYING \
ChangeLog \
ChangeLog.scm \
Makefile.in \
- PLUGIN \
- acconfig-1.5.h \
+ acconfig.h \
+ aclocal.m4 \
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
+ fd.h.in
c_sources = $(c_files) $(h_files)
-manifest = $(ancillery) $(c_sources)
-
+manifest = $(ancillary) $(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 $@
+.SUFFIXES: .o .c .h .ps .dvi .info .texinfo .scm .x
.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
+ $(CC) -DSCM_MAGIC_SNARFER -E $< | grep "^%%%" | sed -e "s/^%%%//" > $@
.PHONY: all
all: libguile.a
+libpath.h: Makefile
+ echo '/* generated by Makefile */' > libpath.h
+ echo '#define LIBRARY_PATH "$(pkgdatadir)/$(VERSION)"' >> libpath.h
+
+# The `dist' target in the top-level Makefile uses this `dist-dir'
+# target to select the appropriate files for distribution from the
+# directory containing this Makefile.
+.PHONY: dist-dir
+dist-dir:
+ mkdir ${DISTDIR}
+ for f in ${manifest}; do \
+ ln ${srcdir}/$$f ${DISTDIR}; \
+ done
+ mkdir ${DISTDIR}/PLUGIN
+ for f in REQ greet guile.config guile.libs; do \
+ ln ${srcdir}/PLUGIN/$$f ${DISTDIR}/PLUGIN; \
+ done
+
SUBDIR=.
manifest:
for file in $(manifest) ; \
@@ -428,22 +418,23 @@ libguile.a: $(libobjs)
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); \
+ ln -f -s libguile$(VERSION).a $(libdir)/libguile.a
+ test -d $(includedir) || mkdir $(includedir)
+ test -d $(innerincludedir) || mkdir $(innerincludedir)
+ for h in $(installed_h_files); do \
+ $(INSTALL_DATA) $(srcdir)/$$h $(includedir); \
+ done
+ $(INSTALL_DATA) scmconfig.h $(innerincludedir)
+ for h in $(inner_h_files); do \
+ $(INSTALL_DATA) $(srcdir)/$$h $(innerincludedir); \
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
+ -rm $(libdir)/libguile.a
+ -rm -rf $(guileincludedir)
+ -rm $(includedir)/guile
TAGS:
@@ -456,6 +447,7 @@ clean:
-rm -f libguile.a
-rm -f $(libobjs)
-rm -f $(gen_c_files)
+ -rm -f libpath.h
distclean: clean
-rm -f config.cache
@@ -463,6 +455,7 @@ distclean: clean
-rm -f config.status
-rm -f Makefile
-rm -f scmconfig.h
+ -rm -f fd.h
realclean: distclean
@@ -474,511 +467,373 @@ 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
+ @gcc -MM -I. -I.. $(DEPENDS_CFLAGS) $(c_files)
###
-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
+alist.o: alist.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h eq.h \
+ alist.h alist.x
+append.o: append.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ append.h append.x
+appinit.o: appinit.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h
+arbiters.o: arbiters.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h smob.h \
+ ports.h genio.h markers.h \
+ arbiters.h arbiters.x
+async.o: async.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h eval.h \
+ throw.h smob.h ports.h genio.h \
+ markers.h async.x
+boolean.o: boolean.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ boolean.x
+chars.o: chars.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ chars.h chars.x
+continuations.o: continuations.c _scm.h __scm.h \
+ scmconfig.h tags.h error.h \
+ __scm.h print.h options.h pairs.h list.h gc.h \
+ gsubr.h procs.h numbers.h symbols.h boolean.h strings.h vectors.h \
+ root.h ports.h async.h stackchk.h continuations.h \
+ debug.h debug.h dynwind.h continuations.h continuations.x
+debug.o: debug.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h eval.h \
+ throw.h genio.h smob.h ports.h genio.h \
+ markers.h procprop.h srcprop.h alist.h continuations.h \
+ strports.h read.h feature.h debug.h debug.x
+dynwind.o: dynwind.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h eval.h \
+ alist.h dynwind.h dynwind.x
+eq.o: eq.c _scm.h __scm.h scmconfig.h tags.h \
+ error.h __scm.h print.h options.h pairs.h \
+ list.h gc.h gsubr.h procs.h numbers.h symbols.h boolean.h strings.h \
+ vectors.h root.h ports.h async.h ramap.h stackchk.h \
+ continuations.h debug.h strorder.h smob.h \
+ ports.h genio.h markers.h unif.h \
+ eq.h eq.x
+error.o: error.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ genio.h throw.h error.x
+eval.o: eval.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ debug.h append.h alist.h sequences.h eq.h continuations.h throw.h \
+ smob.h ports.h genio.h markers.h \
+ markers.h procprop.h hashtab.h hash.h srcprop.h stackchk.h \
+ continuations.h debug.h eval.h eval.c eval.x
+extchrs.o: extchrs.c extchrs.h
+fdsocket.o: fdsocket.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ filesys.h unif.h fdsocket.h fdsocket.x
+feature.o: feature.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ feature.h feature.x
+filesys.o: filesys.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ genio.h smob.h ports.h genio.h \
+ markers.h filesys.h filesys.x
+fports.o: fports.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ markers.h fports.h ports.h fports.x
+gc.o: gc.c _scm.h __scm.h scmconfig.h tags.h \
+ error.h __scm.h print.h options.h pairs.h \
+ list.h gc.h gsubr.h procs.h numbers.h symbols.h boolean.h strings.h \
+ vectors.h root.h ports.h async.h stime.h stackchk.h \
+ continuations.h debug.h struct.h genio.h \
+ weaks.h smob.h ports.h genio.h \
+ markers.h unif.h gc.x
+gdbint.o: gdbint.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h tag.h \
+ strports.h read.h eval.h chars.h gdbint.h gdb_interface.h
+genio.o: genio.c extchrs.h _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ chars.h genio.h
+gsubr.o: gsubr.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ genio.h
+hash.o: hash.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ chars.h hash.h hash.x
+hashtab.o: hashtab.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ alist.h hash.h eval.h hashtab.h hashtab.x
+inet_aton.o: inet_aton.c
+init.o: init.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ alist.h append.h arbiters.h chars.h continuations.h debug.h dynwind.h \
+ eq.h eval.h fdsocket.h feature.h filesys.h fports.h \
+ ports.h gdbint.h hash.h hashtab.h ioext.h kw.h load.h \
+ mallocs.h mbstrings.h symbols.h objprop.h options.h \
+ posix.h procprop.h ramap.h read.h scmsigs.h sequences.h simpos.h \
+ smob.h genio.h markers.h socket.h srcprop.h \
+ stackchk.h continuations.h debug.h stime.h \
+ strop.h strorder.h strports.h struct.h tag.h throw.h unif.h \
+ variable.h version.h vports.h weaks.h init.h
+ioext.o: ioext.c fd.h _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ fports.h ports.h ioext.h ioext.x
+kw.o: kw.c _scm.h __scm.h scmconfig.h tags.h \
+ error.h __scm.h print.h options.h pairs.h \
+ list.h gc.h gsubr.h procs.h numbers.h symbols.h boolean.h strings.h \
+ vectors.h root.h ports.h async.h genio.h mbstrings.h \
+ symbols.h smob.h ports.h genio.h \
+ markers.h kw.h kw.x
+list.o: list.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h eq.h \
+ list.x
+load.o: load.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ libpath.h fports.h ports.h read.h eval.h load.h load.x
+mallocs.o: mallocs.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ genio.h smob.h ports.h genio.h \
+ markers.h mallocs.h
+markers.o: markers.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ markers.h
+mbstrings.o: mbstrings.c extchrs.h _scm.h __scm.h \
+ scmconfig.h tags.h error.h \
+ __scm.h print.h options.h pairs.h list.h gc.h \
+ gsubr.h procs.h numbers.h symbols.h boolean.h strings.h vectors.h \
+ root.h ports.h async.h chars.h unif.h genio.h read.h mbstrings.h \
+ symbols.h mbstrings.x
+numbers.o: numbers.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ genio.h unif.h numbers.x
+objprop.o: objprop.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ hashtab.h alist.h weaks.h objprop.h objprop.x
+options.o: options.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ options.h options.x
+pairs.o: pairs.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ pairs.x
+ports.o: ports.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ genio.h chars.h markers.h fports.h ports.h strports.h \
+ vports.h ports.x
+posix.o: posix.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ fports.h ports.h genio.h scmsigs.h read.h unif.h \
+ feature.h sequences.h posix.h posix.x
+print.o: print.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ chars.h genio.h mbstrings.h symbols.h smob.h \
+ ports.h genio.h markers.h eval.h \
+ procprop.h read.h weaks.h unif.h alist.h struct.h print.x
+procprop.o: procprop.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ alist.h eval.h procprop.h procprop.x
+procs.o: procs.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ procs.x
+ramap.o: ramap.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h unif.h \
+ smob.h ports.h genio.h markers.h \
+ chars.h eq.h eval.h feature.h ramap.h ramap.x
+read.o: read.c extchrs.h _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ chars.h genio.h eval.h unif.h mbstrings.h symbols.h kw.h \
+ alist.h srcprop.h hashtab.h hash.h read.h read.x
+root.o: root.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ stackchk.h continuations.h debug.h dynwind.h \
+ eval.h genio.h smob.h ports.h genio.h \
+ markers.h throw.h root.x
+scmsigs.o: scmsigs.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ scmsigs.h scmsigs.x
+sequences.o: sequences.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ sequences.h sequences.x
+simpos.o: simpos.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ scmsigs.h simpos.h simpos.x
+smob.o: smob.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h smob.h \
+ ports.h genio.h markers.h
+socket.o: socket.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ feature.h socket.h socket.x
+srcprop.o: srcprop.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h smob.h \
+ ports.h genio.h markers.h alist.h \
+ debug.h hashtab.h hash.h weaks.h srcprop.h srcprop.x
+stackchk.o: stackchk.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ genio.h stackchk.h continuations.h debug.h \
+ stackchk.x
+stime.o: stime.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ stime.h stime.x
+strerror.o: strerror.c
+strings.o: strings.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ chars.h strings.x
+strop.o: strop.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ chars.h strop.h strop.x
+strorder.o: strorder.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ chars.h strorder.h strorder.x
+strports.o: strports.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h unif.h \
+ eval.h strports.h strports.x
+struct.o: struct.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ chars.h struct.h struct.x
+symbols.o: symbols.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ chars.h eval.h variable.h alist.h mbstrings.h symbols.h \
+ symbols.x
+tag.o: tag.c _scm.h __scm.h scmconfig.h tags.h \
+ error.h __scm.h print.h options.h pairs.h \
+ list.h gc.h gsubr.h procs.h numbers.h symbols.h boolean.h strings.h \
+ vectors.h root.h ports.h async.h chars.h struct.h tag.h tag.x
+throw.o: throw.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ genio.h smob.h ports.h genio.h \
+ markers.h alist.h eval.h dynwind.h debug.h \
+ continuations.h stackchk.h continuations.h \
+ debug.h throw.h throw.x
+unif.o: unif.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ chars.h eval.h genio.h smob.h ports.h genio.h \
+ markers.h sequences.h strop.h feature.h unif.h ramap.h \
+ unif.x
+variable.o: variable.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ genio.h smob.h ports.h genio.h \
+ markers.h variable.h variable.x
+vectors.o: vectors.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h eq.h \
+ vectors.x
+version.o: version.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ version.h version.x
+vports.o: vports.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h eval.h \
+ chars.h fports.h ports.h vports.h vports.x
+weaks.o: weaks.c _scm.h __scm.h scmconfig.h \
+ tags.h error.h __scm.h print.h \
+ options.h pairs.h list.h gc.h gsubr.h procs.h numbers.h \
+ symbols.h boolean.h strings.h vectors.h root.h ports.h async.h \
+ weaks.h weaks.x
diff --git a/libguile/__scm.h b/libguile/__scm.h
index e3c5772ca..8220d7e4c 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -1,5 +1,3 @@
-/* DO NOT EDIT --- AUTO-GENERATED --- DO NOT EDIT */
-#line 1 "__scm.hd"
/* classes: h_files */
#ifndef __SCMH
@@ -97,21 +95,22 @@
/* {Unsupported Options}
*
- * These must be defined.
+ * These must be defined as given here.
*/
#define CCLO
-#define SICP
+
+/* Guile Scheme supports the #f/() distinction; Guile Lisp won't. We
+ have horrible plans for their unification. */
+#undef SICP
-/* Random options (net yet supported or in final form). */
+/* Random options (not yet supported or in final form). */
-#undef DEBUG_EXTENSIONS
-#undef READER_EXTENSIONS
-#undef SCM_STACK_LIMIT 20000
-#undef NO_CEVAL_STACK_CHECK
+#define STACK_CHECKING
+#undef NO_CEVAL_STACK_CHECKING
#undef LONGLONGS
/* Some auto-generated .h files contain unused prototypes
@@ -122,20 +121,36 @@ typedef unsigned long ulong_long;
+/* What did the configure script discover about the outside world? */
+#include "libguile/scmconfig.h"
+
+
+/* Write prototype declarations like this:
+ int foo SCM_P ((int a, int b));
+ At definitions, use K&R style declarations, but make sure there's a
+ declarative prototype (as above) in scope. This will give you
+ argument type checking, when available, and be harmless otherwise. */
+#ifdef __STDC__
+# define SCM_P(x) x
+#else
+# define SCM_P(x) ()
+#endif
+
+
/* Define
*
- * SCM_CHAR_SCM_CODE_LIMIT == UCHAR_MAX + 1
+ * SCM_CHAR_CODE_LIMIT == UCHAR_MAX + 1
* SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2)
* SCM_MOST_NEGATIVE_FIXNUM == SCM_SRS((long)LONG_MIN, 2)
*/
-#ifdef HAVE_LIMITSH
+#ifdef HAVE_LIMITS_H
# include <limits.h>
# ifdef UCHAR_MAX
-# define SCM_CHAR_SCM_CODE_LIMIT (UCHAR_MAX+1L)
+# define SCM_CHAR_CODE_LIMIT (UCHAR_MAX+1L)
# else
-# define SCM_CHAR_SCM_CODE_LIMIT 256L
+# define SCM_CHAR_CODE_LIMIT 256L
# endif /* def UCHAR_MAX */
# define SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2)
# ifdef _UNICOS /* Stupid cray bug */
@@ -144,18 +159,33 @@ typedef unsigned long ulong_long;
# define SCM_MOST_NEGATIVE_FIXNUM SCM_SRS((long)LONG_MIN, 2)
# endif /* UNICOS */
#else
-# define SCM_CHAR_SCM_CODE_LIMIT 256L
+# define SCM_CHAR_CODE_LIMIT 256L
# define SCM_MOST_POSITIVE_FIXNUM ((long)((unsigned long)~0L>>3))
# if (0 != ~0)
# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1)
# else
# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM)
# endif /* (0 != ~0) */
-#endif /* def HAVE_LIMITSH */
+#endif /* def HAVE_LIMITS_H */
-#include <scmconfig.h>
-#include "tags.h"
+#ifdef STDC_HEADERS
+# include <stdlib.h>
+# ifdef AMIGA
+# include <stddef.h>
+# endif /* def AMIGA */
+# define scm_sizet size_t
+#else
+# ifdef _SIZE_T
+# define scm_sizet size_t
+# else
+# define scm_sizet unsigned int
+# endif /* def _SIZE_T */
+#endif /* def STDC_HEADERS */
+
+
+
+#include "libguile/tags.h"
#ifdef vms
@@ -180,7 +210,6 @@ typedef unsigned long ulong_long;
# 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.
@@ -213,8 +242,18 @@ typedef long SCM_STACKITEM;
#endif
+#ifndef USE_THREADS
+#define SCM_THREADS_SWITCHING_CODE
+#endif
+
extern unsigned int scm_async_clock;
-#define SCM_ASYNC_TICK if (0 == --scm_async_clock) scm_async_click ()
+#define SCM_ASYNC_TICK \
+{ \
+ if (0 == --scm_async_clock) \
+ scm_async_click (); \
+ SCM_THREADS_SWITCHING_CODE; \
+} \
+
#ifdef SCM_CAREFUL_INTS
#define SCM_CHECK_NOT_DISABLED \
@@ -286,28 +325,28 @@ extern unsigned int scm_async_clock;
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 \
+ /* #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_OVSCM_FLOW 9 */
#define SCM_OUTOFRANGE 10
#define SCM_NALLOC 11
-#define SCM_STACK_SCM_OVSCM_FLOW 12
-#define SCM_EXIT 13
+ /* #define SCM_STACK_OVFLOW 12 */
+ /* #define SCM_EXIT 13 */
/* (...still matching scm_errmsgs) These
@@ -329,6 +368,7 @@ extern unsigned int scm_async_clock;
#define SCM_ORD_SIG(X) ((X) + SCM_HUP_SIGNAL)
#define SCM_NUM_SIGS (SCM_SIG_ORD (SCM_TICK_SIGNAL) + 1)
+#if 0
struct errdesc
{
char *msg;
@@ -338,6 +378,7 @@ struct errdesc
extern struct errdesc scm_errmsgs[];
+#endif
diff --git a/libguile/__scm.hd b/libguile/__scm.hd
deleted file mode 100644
index e69de29bb..000000000
--- a/libguile/__scm.hd
+++ /dev/null
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 1c7e74ebc..d6003cddd 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -44,7 +44,29 @@
*/
-#include "libguile.h"
+#include "__scm.h"
+
+/* Include headers for those files central to the implementation. The
+ rest should be explicitly #included in the C files themselves. */
+#include "error.h" /* Everyone signals errors. */
+#include "print.h" /* Everyone needs to print. */
+#include "pairs.h" /* Everyone conses. */
+#include "list.h" /* Everyone makes lists. */
+#include "gc.h" /* Everyone allocates. */
+#include "gsubr.h" /* Everyone defines global functions. */
+#include "procs.h" /* Same. */
+#include "numbers.h" /* Everyone deals with fixnums. */
+#include "symbols.h" /* For length, chars, values, miscellany. */
+#include "boolean.h" /* Everyone wonders about the truth. */
+#include "strings.h" /* Everyone loves string. */
+#include "vectors.h" /* Vectors are used for structures a lot. */
+#include "root.h" /* Everyone uses these objects. */
+#include "ports.h" /* Everyone does I/O. */
+#include "async.h" /* Everyone allows/disallows ints. */
+#ifdef USE_THREADS
+#include "../threads/threads.h" /* Some thread packages does switching
+ at async ticks. */
+#endif
/* On VMS, GNU C's errno.h contains a special hack to get link attributes
* for errno correct for linking to the C RTL.
@@ -90,9 +112,9 @@
#ifndef SCM_MAGIC_SNARFER
#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
- static char RANAME[]=STR;
+ static char RANAME[]=STR
#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
- static char RANAME[]=STR;
+ static char RANAME[]=STR
#else
#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, CFN)
diff --git a/libguile/acconfig.h b/libguile/acconfig.h
new file mode 100644
index 000000000..d1337e086
--- /dev/null
+++ b/libguile/acconfig.h
@@ -0,0 +1,49 @@
+/* acconfig.h --- documentation for symbols possibly defined in scmconfig.h
+ Jim Blandy <jimb@cyclic.com> --- August 1996 */
+
+/* Define these two if you want support for debugging of Scheme
+ programs. */
+#undef DEBUG_EXTENSIONS
+#undef READER_EXTENSIONS
+
+/* Define this if your system has a way to set a stdio stream's file
+ descriptor. You should also copy fd.h.in to fd.h, and give the
+ macro SET_FILE_FD_FIELD an appropriate definition. See
+ configure.in for more details. */
+#undef HAVE_FD_SETTER
+
+/* Define this if your system defines struct linger, for use with the
+ getsockopt and setsockopt system calls. */
+#undef HAVE_STRUCT_LINGER
+
+/* Define this if floats are the same size as longs. */
+#undef SCM_SINGLES
+
+/* Define this if a callee's stack frame has a higher address than the
+ caller's stack frame. On most machines, this is not the case. */
+#undef SCM_STACK_GROWS_UP
+
+/* Define this if <utime.h> doesn't define struct utimbuf unless
+ _POSIX_SOURCE is #defined. */
+#undef UTIMBUF_NEEDS_POSIX
+
+/* Define these to indicate the current version of Guile. These
+ values are supposed to be supplied by the configuration system. */
+#undef GUILE_MAJOR_VERSION
+#undef GUILE_MINOR_VERSION
+#undef GUILE_VERSION
+
+/* Define if using cooperative multithreading. */
+#undef USE_COOP_THREADS
+
+/* Define if using "FSU" pthreads. */
+#undef USE_FSU_PTHREADS
+
+/* Define if using MIT pthreads. */
+#undef USE_MIT_PTHREADS
+
+/* Define if using PCthreads pthreads. */
+#undef USE_PCTHREADS_PTHREADS
+
+/* Define if using any sort of threads. */
+#undef USE_THREADS
diff --git a/libguile/aclocal.m4 b/libguile/aclocal.m4
new file mode 100644
index 000000000..a0e03479b
--- /dev/null
+++ b/libguile/aclocal.m4
@@ -0,0 +1,19 @@
+dnl On the NeXT, #including <utime.h> doesn't give you a definition for
+dnl struct utime, unless you #define _POSIX_SOURCE.
+
+AC_DEFUN(GUILE_STRUCT_UTIMBUF, [
+ AC_CACHE_CHECK([whether we need POSIX to get struct utimbuf],
+ guile_cv_struct_utimbuf_needs_posix,
+ [AC_TRY_CPP([
+#ifdef __EMX__
+#include <sys/utime.h>
+#else
+#include <utime.h>
+#endif
+struct utime blah;
+],
+ guile_cv_struct_utimbuf_needs_posix=no,
+ guile_cv_struct_utimbuf_needs_posix=yes)])
+ if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then
+ AC_DEFINE(UTIMBUF_NEEDS_POSIX)
+ fi])
diff --git a/libguile/alist.c b/libguile/alist.c
index 85c4395af..95a891809 100644
--- a/libguile/alist.c
+++ b/libguile/alist.c
@@ -41,6 +41,10 @@
#include <stdio.h>
#include "_scm.h"
+#include "eq.h"
+#include "list.h"
+
+#include "alist.h"
diff --git a/libguile/alist.h b/libguile/alist.h
index f0f90a4df..4d86e2a37 100644
--- a/libguile/alist.h
+++ b/libguile/alist.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/append.c b/libguile/append.c
index 4f09a1dcf..551d8d369 100644
--- a/libguile/append.c
+++ b/libguile/append.c
@@ -42,6 +42,9 @@
#include <stdio.h>
#include "_scm.h"
+#include "list.h"
+
+#include "append.h"
diff --git a/libguile/append.h b/libguile/append.h
index 33197f976..04b1a8a20 100644
--- a/libguile/append.h
+++ b/libguile/append.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/arbiters.c b/libguile/arbiters.c
index d5e374b42..da7b5dccc 100644
--- a/libguile/arbiters.c
+++ b/libguile/arbiters.c
@@ -42,6 +42,9 @@
#include <stdio.h>
#include "_scm.h"
+#include "smob.h"
+
+#include "arbiters.h"
/* {Arbiters}
@@ -55,19 +58,19 @@ static long scm_tc16_arbiter;
#ifdef __STDC__
static int
-prinarb (SCM exp, SCM port, int writing)
+prinarb (SCM exp, SCM port, scm_print_state *pstate)
#else
static int
-prinarb (exp, port, writing)
+prinarb (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#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_iprin1 (SCM_CDR (exp), port, pstate);
scm_gen_putc ('>', port);
return !0;
}
diff --git a/libguile/arbiters.h b/libguile/arbiters.h
index 2a88a6ebc..390770d5e 100644
--- a/libguile/arbiters.h
+++ b/libguile/arbiters.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
#ifdef __STDC__
diff --git a/libguile/async.c b/libguile/async.c
index 7a942270e..1409d155a 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -43,7 +43,15 @@
#include <stdio.h>
#include <signal.h>
#include "_scm.h"
+#include "eval.h"
+#include "throw.h"
+#include "smob.h"
+#include "async.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
@@ -294,13 +302,13 @@ scm_deliver_signal (num)
#ifdef __STDC__
static int
-print_async (SCM exp, SCM port, int writing)
+print_async (SCM exp, SCM port, scm_print_state *pstate)
#else
static int
-print_async (exp, port, writing)
+print_async (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
scm_gen_puts (scm_regular_string, "#<async ", port);
@@ -652,10 +660,18 @@ scm_take_signal (n)
SCM ignored;
if (!scm_ints_disabled)
{
- SCM_NEWCELL (ignored); /* In case we interrupted SCM_NEWCELL,
- * throw out the possibly already allocated
- * free cell.
- */
+ /* For reasons of speed, the SCM_NEWCELL macro doesn't defer
+ interrupts. Instead, it first sets its argument to point to
+ the first cell in the list, and then advances the freelist
+ pointer to the next cell. Now, if this procedure is
+ interrupted, the only anomalous state possible is to have
+ both SCM_NEWCELL's argument and scm_freelist pointing to the
+ same cell. To deal with this case, we always throw away the
+ first cell in scm_freelist here.
+
+ At least, that's the theory. I'm not convinced that that's
+ the only anomalous path we need to worry about. */
+ SCM_NEWCELL (ignored);
}
scm_system_async_mark (system_signal_asyncs[SCM_SIG_ORD(n)]);
return SCM_BOOL_F;
@@ -702,7 +718,7 @@ scm_init_async ()
{
SCM a_thunk;
scm_tc16_async = scm_newsmob (&async_smob);
- symbol_signal = SCM_CAR (scm_sysintern ("signal", strlen ("signal")));
+ symbol_signal = SCM_CAR (scm_sysintern ("signal", SCM_UNDEFINED));
scm_permanent_object (symbol_signal);
/* These are in the opposite order of delivery priortity.
@@ -730,7 +746,7 @@ scm_init_async ()
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"));
+ handler_var = scm_sysintern ("signal-handler", SCM_UNDEFINED);
SCM_SETCDR (handler_var, SCM_BOOL_F);
scm_permanent_object (handler_var);
#include "async.x"
diff --git a/libguile/async.h b/libguile/async.h
index 2e99025ac..26ebee972 100644
--- a/libguile/async.h
+++ b/libguile/async.h
@@ -44,12 +44,11 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
-extern unsigned int scm_async_clock;
extern unsigned int scm_mask_ints;
diff --git a/libguile/boolean.c b/libguile/boolean.c
index cc8c63382..36477c21a 100644
--- a/libguile/boolean.c
+++ b/libguile/boolean.c
@@ -42,6 +42,8 @@
#include <stdio.h>
#include "_scm.h"
+
+#include "boolean.h"
diff --git a/libguile/boolean.h b/libguile/boolean.h
index 8c9b6a7e7..600c31966 100644
--- a/libguile/boolean.h
+++ b/libguile/boolean.h
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/chars.c b/libguile/chars.c
index 70ec0ab82..773be4d81 100644
--- a/libguile/chars.c
+++ b/libguile/chars.c
@@ -44,6 +44,7 @@
#include <ctype.h>
#include "_scm.h"
+#include "chars.h"
@@ -383,8 +384,8 @@ scm_char_downcase(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_upcase_table[SCM_CHAR_CODE_LIMIT];
+static unsigned char scm_downcase_table[SCM_CHAR_CODE_LIMIT];
static unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz";
static unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
@@ -397,7 +398,7 @@ scm_tables_prehistory ()
#endif
{
int i;
- for (i = 0; i < SCM_CHAR_SCM_CODE_LIMIT; i++)
+ for (i = 0; i < SCM_CHAR_CODE_LIMIT; i++)
scm_upcase_table[i] = scm_downcase_table[i] = i;
for (i = 0; i < sizeof scm_lowers / sizeof (char); i++)
{
diff --git a/libguile/chars.h b/libguile/chars.h
index 83afcfa7e..f985a3509 100644
--- a/libguile/chars.h
+++ b/libguile/chars.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
/* Immediate Characters
diff --git a/libguile/configure b/libguile/configure
index 83e29e67b..cc8e76eaa 100755
--- a/libguile/configure
+++ b/libguile/configure
@@ -1,7 +1,7 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated automatically using autoconf version 2.9
+# Generated automatically using autoconf version 2.10
# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
#
# This configure script is free software; the Free Software Foundation
@@ -11,6 +11,10 @@
ac_help=
ac_default_prefix=/usr/local
# Any additions from configure.in:
+ac_help="$ac_help
+ --disable-debug Don't include debugging support"
+ac_help="$ac_help
+ --with-threads thread interface"
# Initialize some variables set by options.
# The variables have the same names as the options, with
@@ -330,7 +334,7 @@ EOF
verbose=yes ;;
-version | --version | --versio | --versi | --vers)
- echo "configure generated by autoconf version 2.9"
+ echo "configure generated by autoconf version 2.10"
exit 0 ;;
-with-* | --with-*)
@@ -516,6 +520,32 @@ fi
. $srcdir/../GUILE-VERSION
+#--------------------------------------------------------------------
+#
+# User options
+#
+#--------------------------------------------------------------------
+
+# Check whether --enable-debug or --disable-debug was given.
+if test "${enable_debug+set}" = set; then
+ enableval="$enable_debug"
+ :
+fi
+
+if test "$enableval" != n && test "$enableval" != no; then
+ cat >> confdefs.h <<\EOF
+#define DEBUG_EXTENSIONS 1
+EOF
+
+ cat >> confdefs.h <<\EOF
+#define READER_EXTENSIONS 1
+EOF
+
+ LIBOBJS="debug.o srcprop.o $LIBOBJS"
+fi
+
+#--------------------------------------------------------------------
+
test -z "$CFLAGS" && CFLAGS=-g
test -z "$LDFLAGS" && LDFLAGS=-g
@@ -605,7 +635,7 @@ else
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
+if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:639: \"$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
@@ -657,13 +687,13 @@ else
# 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"
+#line 691 "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; }
+{ (eval echo configure:697: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
:
@@ -672,13 +702,13 @@ else
rm -rf conftest*
CPP="${CC-cc} -E -traditional-cpp"
cat > conftest.$ac_ext <<EOF
-#line 676 "configure"
+#line 706 "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; }
+{ (eval echo configure:712: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
:
@@ -729,7 +759,7 @@ fi
echo $ac_n "checking for AIX""... $ac_c" 1>&6
cat > conftest.$ac_ext <<EOF
-#line 733 "configure"
+#line 763 "configure"
#include "confdefs.h"
#ifdef _AIX
yes
@@ -776,12 +806,12 @@ 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"
+#line 810 "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; }
+{ (eval echo configure:815: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -817,12 +847,155 @@ EOF
fi
+
+
+
+
+echo $ac_n "checking "threads package type"""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'cy_cv_threads_package'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+if eval "test \"`echo '$''{'cy_cv_threads_cflags'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+if eval "test \"`echo '$''{'cy_cv_threads_libs'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+use_threads=no;
+# Check whether --with-threads or --without-threads was given.
+if test "${with_threads+set}" = set; then
+ withval="$with_threads"
+ use_threads=$withval
+else
+ use_threads=no
+fi
+
+test -n "$use_threads" || use_threads=qt
+threads_package=unknown
+if test "$use_threads" != no; then
+ if test "$use_threads" = yes || test "$use_threads" = qt; then
+ # Look for qt in source directory. This is a hack: we look in
+ # "./qt" because this check might be run at the top level.
+ if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then
+ threads_package=COOP
+ cy_cv_threads_cflags="-I$srcdir/../qt -I../qt"
+ cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a"
+ fi
+ else
+ if test -f $use_threads/qt.c; then
+ # FIXME seems as though we should try to use an installed qt here.
+ threads_package=COOP
+ cy_cv_threads_cflags="-I$use_threads -I../qt"
+ cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a"
+ fi
+ fi
+ if test "$use_threads" = pthreads; then
+ # Look for pthreads in srcdir. See above to understand why
+ # we always set threads_package.
+ if test -f $srcdir/../../pthreads/pthreads/queue.c \
+ || test -f $srcdir/../pthreads/pthreads/queue.c; then
+ threads_package=MIT
+ cy_cv_threads_cflags="-I$srcdir/../../pthreads/include"
+ cy_cv_threads_libs="-L../../pthreads/lib -lpthread"
+ fi
+ fi
+ saved_CPP="$CPPFLAGS"
+ saved_LD="$LDFLAGS"
+ saved_LIBS="$LIBS"
+ if test "$threads_package" = unknown; then
+ CPPFLAGS="-I$use_threads/include"
+ LDFLAGS="-L$use_threads/lib"
+ LIBS="-lgthreads -lmalloc"
+ cat > conftest.$ac_ext <<EOF
+#line 914 "configure"
+#include "confdefs.h"
+#include <pthread.h>
+int main() { return 0; }
+int t() {
+
+pthread_equal(NULL,NULL);
+
+; return 0; }
+EOF
+if { (eval echo configure:924: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+ rm -rf conftest*
+ threads_package=FSU
+fi
+rm -f conftest*
+
+ fi
+ if test "$threads_package" = unknown; then
+ LIBS="-lpthread"
+ cat > conftest.$ac_ext <<EOF
+#line 934 "configure"
+#include "confdefs.h"
+#include <pthread.h>
+int main() { return 0; }
+int t() {
+
+pthread_equal(NULL,NULL);
+
+; return 0; }
+EOF
+if { (eval echo configure:944: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+ rm -rf conftest*
+ threads_package=MIT
+fi
+rm -f conftest*
+
+ fi
+ if test "$threads_package" = unknown; then
+ LIBS="-lpthreads"
+ cat > conftest.$ac_ext <<EOF
+#line 954 "configure"
+#include "confdefs.h"
+#include <pthread.h>
+int main() { return 0; }
+int t() {
+
+pthread_equal(NULL,NULL);
+
+; return 0; }
+EOF
+if { (eval echo configure:964: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+ rm -rf conftest*
+ threads_package=PCthreads
+fi
+rm -f conftest*
+
+ fi
+ cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags"
+ cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs"
+ cy_cv_threads_package=$threads_package
+ CPPFLAGS="$saved_CPP"
+ LDFLAGS="$saved_LD"
+ LIBS="$saved_LIBS"
+ if test "$threads_package" = unknown; then
+ { echo "configure: error: "cannot find thread library installation"" 1>&2; exit 1; }
+ fi
+fi
+
+fi
+
+
+fi
+
+
+fi
+
+echo "$ac_t""$cy_cv_threads_package" 1>&6
+
+CFLAGS="$CPPFLAGS $CFLAGS"
+
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"
+#line 999 "configure"
#include "confdefs.h"
int main() { return 0; }
@@ -872,7 +1045,7 @@ ccp = (char const *const *) p;
; return 0; }
EOF
-if { (eval echo configure:876: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1049: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_c_const=yes
else
@@ -901,11 +1074,11 @@ else
ac_cv_c_cross=yes
else
cat > conftest.$ac_ext <<EOF
-#line 905 "configure"
+#line 1078 "configure"
#include "confdefs.h"
main(){return(0);}
EOF
-{ (eval echo configure:909: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
+{ (eval echo configure:1082: \"$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
@@ -923,7 +1096,7 @@ 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"
+#line 1100 "configure"
#include "confdefs.h"
#include <stdlib.h>
#include <stdarg.h>
@@ -931,7 +1104,7 @@ else
#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; }
+{ (eval echo configure:1108: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -946,7 +1119,7 @@ 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"
+#line 1123 "configure"
#include "confdefs.h"
#include <string.h>
EOF
@@ -964,7 +1137,7 @@ 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"
+#line 1141 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
@@ -985,7 +1158,7 @@ if test "$cross_compiling" = yes; then
:
else
cat > conftest.$ac_ext <<EOF
-#line 989 "configure"
+#line 1162 "configure"
#include "confdefs.h"
#include <ctype.h>
#define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
@@ -996,7 +1169,7 @@ 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; }
+{ (eval echo configure:1173: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
if test -s conftest && (./conftest; exit) 2>/dev/null; then
:
else
@@ -1024,7 +1197,7 @@ 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"
+#line 1201 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <$ac_hdr>
@@ -1033,7 +1206,7 @@ int t() {
DIR *dirp = 0;
; return 0; }
EOF
-if { (eval echo configure:1037: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1210: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
eval "ac_cv_header_dirent_$ac_safe=yes"
else
@@ -1057,16 +1230,18 @@ 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'`
+ac_lib_var=`echo dir'_'opendir | tr './+\055' '__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"
+#line 1241 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
char opendir();
int main() { return 0; }
@@ -1074,7 +1249,7 @@ int t() {
opendir()
; return 0; }
EOF
-if { (eval echo configure:1078: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+if { (eval echo configure:1253: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -1094,16 +1269,18 @@ fi
else
echo $ac_n "checking for -lx""... $ac_c" 1>&6
-ac_lib_var=`echo x_opendir | tr '.-/+' '___p'`
+ac_lib_var=`echo x'_'opendir | tr './+\055' '__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"
+#line 1280 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
char opendir();
int main() { return 0; }
@@ -1111,7 +1288,7 @@ int t() {
opendir()
; return 0; }
EOF
-if { (eval echo configure:1115: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+if { (eval echo configure:1292: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@@ -1136,7 +1313,7 @@ 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"
+#line 1317 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/time.h>
@@ -1146,7 +1323,7 @@ int t() {
struct tm *tp;
; return 0; }
EOF
-if { (eval echo configure:1150: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1327: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_header_time=yes
else
@@ -1170,7 +1347,7 @@ 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"
+#line 1351 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/wait.h>
@@ -1187,7 +1364,7 @@ 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
+if { (eval echo configure:1368: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_header_sys_wait_h=yes
else
@@ -1206,7 +1383,7 @@ 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
+for ac_hdr in libc.h limits.h malloc.h memory.h string.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/types.h sys/utime.h time.h unistd.h utime.h
do
ac_safe=`echo "$ac_hdr" | tr './\055' '___'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
@@ -1214,12 +1391,12 @@ 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"
+#line 1395 "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; }
+{ (eval echo configure:1400: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
@@ -1249,7 +1426,7 @@ 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"
+#line 1430 "configure"
#include "confdefs.h"
#include <sys/types.h>
EOF
@@ -1285,7 +1462,7 @@ else
ac_cv_type_getgroups=cross
else
cat > conftest.$ac_ext <<EOF
-#line 1289 "configure"
+#line 1466 "configure"
#include "confdefs.h"
/* Thanks to Mike Rendell for this test. */
@@ -1310,7 +1487,7 @@ main()
}
EOF
-{ (eval echo configure:1314: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
+{ (eval echo configure:1491: \"$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
@@ -1320,7 +1497,7 @@ fi
rm -fr conftest*
if test $ac_cv_type_getgroups = cross; then
cat > conftest.$ac_ext <<EOF
-#line 1324 "configure"
+#line 1501 "configure"
#include "confdefs.h"
#include <unistd.h>
EOF
@@ -1348,7 +1525,7 @@ 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"
+#line 1529 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <signal.h>
@@ -1366,7 +1543,7 @@ int t() {
int i;
; return 0; }
EOF
-if { (eval echo configure:1370: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1547: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_type_signal=void
else
@@ -1383,20 +1560,53 @@ cat >> confdefs.h <<EOF
EOF
+echo $ac_n "checking for mode_t""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1569 "configure"
+#include "confdefs.h"
+#include <sys/types.h>
+#if STDC_HEADERS
+#include <stdlib.h>
+#endif
+EOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+ egrep "mode_t" >/dev/null 2>&1; then
+ rm -rf conftest*
+ ac_cv_type_mode_t=yes
+else
+ rm -rf conftest*
+ ac_cv_type_mode_t=no
+fi
+rm -f conftest*
+
+fi
+echo "$ac_t""$ac_cv_type_mode_t" 1>&6
+if test $ac_cv_type_mode_t = no; then
+ cat >> confdefs.h <<\EOF
+#define mode_t int
+EOF
-for ac_func in ftime times geteuid select uname mkdir rmdir getcwd rename putenv setlocale strftime strptime mknod nice lstat readlink symlink sync
+fi
+
+
+for ac_func in ctermid ftime getcwd geteuid lstat mkdir mknod nice putenv readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
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"
+#line 1603 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
char $ac_func();
int main() { return 0; }
@@ -1413,7 +1623,7 @@ $ac_func();
; return 0; }
EOF
-if { (eval echo configure:1417: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+if { (eval echo configure:1627: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
@@ -1436,19 +1646,21 @@ fi
done
-for ac_func in inet_aton
+for ac_func in inet_aton strerror
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"
+#line 1657 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
char $ac_func();
int main() { return 0; }
@@ -1465,7 +1677,7 @@ $ac_func();
; return 0; }
EOF
-if { (eval echo configure:1469: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+if { (eval echo configure:1681: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
@@ -1491,7 +1703,7 @@ 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"
+#line 1707 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/stat.h>
@@ -1500,7 +1712,7 @@ 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
+if { (eval echo configure:1716: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_st_rdev=yes
else
@@ -1524,7 +1736,7 @@ 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"
+#line 1740 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/stat.h>
@@ -1533,7 +1745,7 @@ 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
+if { (eval echo configure:1749: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_st_blksize=yes
else
@@ -1557,7 +1769,7 @@ 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"
+#line 1773 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/stat.h>
@@ -1566,7 +1778,7 @@ 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
+if { (eval echo configure:1782: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_st_blocks=yes
else
@@ -1588,6 +1800,44 @@ else
fi
+ echo $ac_n "checking whether we need POSIX to get struct utimbuf""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'guile_cv_struct_utimbuf_needs_posix'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1809 "configure"
+#include "confdefs.h"
+
+#ifdef __EMX__
+#include <sys/utime.h>
+#else
+#include <utime.h>
+#endif
+struct utime blah;
+
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:1821: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out`
+if test -z "$ac_err"; then
+ rm -rf conftest*
+ guile_cv_struct_utimbuf_needs_posix=no
+else
+ echo "$ac_err" >&5
+ rm -rf conftest*
+ guile_cv_struct_utimbuf_needs_posix=yes
+fi
+rm -f conftest*
+fi
+
+echo "$ac_t""$guile_cv_struct_utimbuf_needs_posix" 1>&6
+ if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then
+ cat >> confdefs.h <<\EOF
+#define UTIMBUF_NEEDS_POSIX 1
+EOF
+
+ fi
+
#--------------------------------------------------------------------
#
# Which way does the stack grow?
@@ -1598,13 +1848,13 @@ 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"
+#line 1852 "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; }
+{ (eval echo configure:1858: \"$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
@@ -1623,11 +1873,11 @@ 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"
+#line 1877 "configure"
#include "confdefs.h"
main () { exit (sizeof(float) != sizeof(long)); }
EOF
-{ (eval echo configure:1631: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
+{ (eval echo configure:1881: \"$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
@@ -1637,9 +1887,38 @@ fi
fi
rm -fr conftest*
+echo $ac_n "checking for struct linger""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'scm_cv_struct_linger'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1896 "configure"
+#include "confdefs.h"
+#include <sys/socket.h>
+int main() { return 0; }
+int t() {
+struct linger lgr; lgr.l_linger = 100
+; return 0; }
+EOF
+if { (eval echo configure:1904: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ scm_cv_struct_linger="yes"
+else
+ rm -rf conftest*
+ scm_cv_struct_linger="no"
+fi
+rm -f conftest*
+fi
+echo "$ac_t""$scm_cv_struct_linger" 1>&6
+if test $scm_cv_struct_linger = yes; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_STRUCT_LINGER 1
+EOF
+fi
+
#--------------------------------------------------------------------
#
# How can you violate a stdio abstraction by setting a stream's fd?
@@ -1650,7 +1929,7 @@ FD_SETTER=""
if test "x$FD_SETTER" = x; then
cat > conftest.$ac_ext <<EOF
-#line 1654 "configure"
+#line 1933 "configure"
#include "confdefs.h"
#include <stdio.h>
@@ -1659,7 +1938,7 @@ int t() {
stdout->_file = 1
; return 0; }
EOF
-if { (eval echo configure:1663: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1942: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
FD_SETTER="((F)->_file = (D))"
fi
@@ -1669,7 +1948,7 @@ fi
if test "x$FD_SETTER" = x; then
cat > conftest.$ac_ext <<EOF
-#line 1673 "configure"
+#line 1952 "configure"
#include "confdefs.h"
#include <stdio.h>
@@ -1678,7 +1957,7 @@ int t() {
stdout->_fileno
; return 0; }
EOF
-if { (eval echo configure:1682: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1961: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
FD_SETTER="((F)->_fileno = (D))"
fi
@@ -1692,8 +1971,63 @@ test "x$FD_SETTER" != x && cat >> confdefs.h <<\EOF
EOF
+#--------------------------------------------------------------------
+#
+# Flags for thread support
+#
+#--------------------------------------------------------------------
+if test "$cy_cv_threads_package" = FSU; then
+ cat >> confdefs.h <<\EOF
+#define USE_FSU_PTHREADS 1
+EOF
+ else if test "$cy_cv_threads_package" = COOP; then
+ cat >> confdefs.h <<\EOF
+#define USE_COOP_THREADS 1
+EOF
+
+ else if test "$cy_cv_threads_package" = MIT; then
+ cat >> confdefs.h <<\EOF
+#define USE_MIT_PTHREADS 1
+EOF
+
+ else if test "$cy_cv_threads_package" = PCthreads; then
+ cat >> confdefs.h <<\EOF
+#define USE_PCTHREADS_PTHREADS 1
+EOF
+
+ else if test "$cy_cv_threads_package" = unknown; then
+ { echo "configure: error: "cannot find threads installation"" 1>&2; exit 1; }
+ fi
+ fi
+ fi
+ fi
+fi
+
+if test "$cy_cv_threads_package" != ""; then
+ cat >> confdefs.h <<\EOF
+#define USE_THREADS 1
+EOF
+
+fi
+
+## If we're using GCC, ask for aggressive warnings.
+case "$GCC" in
+ yes ) CFLAGS="$CFLAGS -Wall -Wpointer-arith" ;;
+esac
+
+cat >> confdefs.h <<EOF
+#define GUILE_MAJOR_VERSION "$GUILE_MAJOR_VERSION"
+EOF
+
+cat >> confdefs.h <<EOF
+#define GUILE_MINOR_VERSION "$GUILE_MINOR_VERSION"
+EOF
+
+cat >> confdefs.h <<EOF
+#define GUILE_VERSION "$GUILE_VERSION"
+EOF
@@ -1780,7 +2114,7 @@ do
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"
+ echo "$CONFIG_STATUS generated by autoconf version 2.10"
exit 0 ;;
-help | --help | --hel | --he | --h)
echo "\$ac_cs_usage"; exit 0 ;;
@@ -1825,8 +2159,6 @@ 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
@@ -1978,6 +2310,12 @@ cat >> $CONFIG_STATUS <<\EOF
echo "$ac_file is unchanged"
rm -f conftest.h
else
+ # Remove last slash and all that follows it. Not all systems have dirname.
+ ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
+ if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
+ # The file is in a subdirectory.
+ test ! -d "$ac_dir" && mkdir "$ac_dir"
+ fi
rm -f $ac_file
mv conftest.h $ac_file
fi
diff --git a/libguile/configure.in b/libguile/configure.in
index ae71726d5..597a885f0 100644
--- a/libguile/configure.in
+++ b/libguile/configure.in
@@ -3,6 +3,22 @@ AC_CONFIG_HEADER(scmconfig.h)
. $srcdir/../GUILE-VERSION
+#--------------------------------------------------------------------
+#
+# User options
+#
+#--------------------------------------------------------------------
+
+AC_ARG_ENABLE(debug,
+[ --disable-debug Don't include debugging support])
+if test "$enableval" != n && test "$enableval" != no; then
+ AC_DEFINE(DEBUG_EXTENSIONS)
+ AC_DEFINE(READER_EXTENSIONS)
+ LIBOBJS="debug.o srcprop.o $LIBOBJS"
+fi
+
+#--------------------------------------------------------------------
+
test -z "$CFLAGS" && CFLAGS=-g
test -z "$LDFLAGS" && LDFLAGS=-g
@@ -14,24 +30,30 @@ AC_AIX
AC_ISC_POSIX
AC_MINIX
+builtin(sinclude, ../aclocal.m4)
+CY_AC_WITH_THREADS
+CFLAGS="$CPPFLAGS $CFLAGS"
+
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_CHECK_HEADERS(libc.h limits.h malloc.h memory.h string.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/types.h sys/utime.h time.h unistd.h utime.h)
AC_TYPE_GETGROUPS
AC_TYPE_SIGNAL
+AC_TYPE_MODE_T
-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_CHECK_FUNCS(ctermid ftime getcwd geteuid lstat mkdir mknod nice putenv readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid)
-AC_REPLACE_FUNCS(inet_aton)
+AC_REPLACE_FUNCS(inet_aton strerror)
AC_STRUCT_ST_RDEV
AC_STRUCT_ST_BLKSIZE
AC_STRUCT_ST_BLOCKS
+GUILE_STRUCT_UTIMBUF
#--------------------------------------------------------------------
#
@@ -49,9 +71,17 @@ AC_TRY_RUN(main () { exit (sizeof(float) != sizeof(long)); },
AC_DEFINE(SCM_SINGLES),,AC_DEFINE(SCM_SINGLES)
AC_MSG_WARN(Guessing that sizeof(long) == sizeof(float) -- see scmconfig.h.in))
-
-
-
+AC_MSG_CHECKING(for struct linger)
+AC_CACHE_VAL(scm_cv_struct_linger,
+ AC_TRY_COMPILE([#include <sys/socket.h>],
+ [struct linger lgr; lgr.l_linger = 100],
+ scm_cv_struct_linger="yes",
+ scm_cv_struct_linger="no"))
+AC_MSG_RESULT($scm_cv_struct_linger)
+if test $scm_cv_struct_linger = yes; then
+ AC_DEFINE(HAVE_STRUCT_LINGER)
+fi
+
#--------------------------------------------------------------------
#
# How can you violate a stdio abstraction by setting a stream's fd?
@@ -86,14 +116,48 @@ dnl
test "x$FD_SETTER" != x && AC_DEFINE(HAVE_FD_SETTER)
+#--------------------------------------------------------------------
+#
+# Flags for thread support
+#
+#--------------------------------------------------------------------
+
+dnl
+dnl Set the appropriate flags!
+dnl
+if test "$cy_cv_threads_package" = FSU; then
+ AC_DEFINE(USE_FSU_PTHREADS, 1)
+ else if test "$cy_cv_threads_package" = COOP; then
+ AC_DEFINE(USE_COOP_THREADS, 1)
+ else if test "$cy_cv_threads_package" = MIT; then
+ AC_DEFINE(USE_MIT_PTHREADS, 1)
+ else if test "$cy_cv_threads_package" = PCthreads; then
+ AC_DEFINE(USE_PCTHREADS_PTHREADS, 1)
+ else if test "$cy_cv_threads_package" = unknown; then
+ AC_MSG_ERROR("cannot find threads installation")
+ fi
+ fi
+ fi
+ fi
+fi
+
+if test "$cy_cv_threads_package" != ""; then
+ AC_DEFINE(USE_THREADS)
+fi
+
+## If we're using GCC, ask for aggressive warnings.
+case "$GCC" in
+ yes ) CFLAGS="$CFLAGS -Wall -Wpointer-arith" ;;
+esac
+AC_DEFINE_UNQUOTED(GUILE_MAJOR_VERSION, "$GUILE_MAJOR_VERSION")
+AC_DEFINE_UNQUOTED(GUILE_MINOR_VERSION, "$GUILE_MINOR_VERSION")
+AC_DEFINE_UNQUOTED(GUILE_VERSION, "$GUILE_VERSION")
AC_SUBST(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)
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 054ed8e56..6acdb87a1 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -42,7 +42,13 @@
#include <stdio.h>
#include "_scm.h"
+#include "stackchk.h"
+#ifdef DEBUG_EXTENSIONS
+#include "debug.h"
+#endif
+#include "dynwind.h"
+#include "continuations.h"
/* {Continuations}
@@ -68,7 +74,7 @@ scm_make_cont (answer)
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_DYNENV (cont) = scm_dynwinds;
SCM_THROW_VALUE = SCM_EOL;
SCM_BASE (cont) = SCM_BASE (rootcont);
SCM_SEQ (cont) = SCM_SEQ (rootcont);
@@ -76,19 +82,19 @@ scm_make_cont (answer)
#else
register SCM_STACKITEM *src, *dst;
+#if 0
{
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
}
}
+#endif
SCM_NEWCELL (cont);
*answer = cont;
@@ -112,14 +118,11 @@ scm_make_cont (answer)
*dst++ = *src++;
#endif /* def CHEAP_CONTINUATIONS */
#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (cont) = last_debug_info_frame;
+ SCM_DFRAME (cont) = scm_last_debug_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
@@ -182,7 +185,7 @@ scm_dynthrow (a)
#endif
#endif /* ndef CHEAP_CONTINUATIONS */
#ifdef DEBUG_EXTENSIONS
- last_debug_info_frame = SCM_DFRAME (cont);
+ scm_last_debug_frame = SCM_DFRAME (cont);
#endif
SCM_THROW_VALUE(cont) = val;
longjmp (SCM_JMPBUF (cont), 1);
diff --git a/libguile/continuations.h b/libguile/continuations.h
index 176d423fc..109a2998b 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/debug.c b/libguile/debug.c
new file mode 100644
index 000000000..b6adab747
--- /dev/null
+++ b/libguile/debug.c
@@ -0,0 +1,626 @@
+/* Debugging extensions for Guile
+ * Copyright (C) 1995, 1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+#include <stdio.h>
+#include "_scm.h"
+#include "eval.h"
+#include "throw.h"
+#include "genio.h"
+#include "smob.h"
+#include "procprop.h"
+#include "srcprop.h"
+#include "alist.h"
+#include "continuations.h"
+#include "strports.h"
+#include "read.h"
+#include "feature.h"
+
+#include "debug.h"
+
+
+/* {Run time control of the debugging evaluator}
+ */
+
+SCM_PROC (s_debug_options, "debug-options-interface", 0, 1, 0, scm_debug_options);
+#ifdef __STDC__
+SCM
+scm_debug_options (SCM setting)
+#else
+SCM
+scm_debug_options (setting)
+ SCM setting;
+#endif
+{
+ SCM ans;
+ SCM_DEFER_INTS;
+ ans = scm_options (setting,
+ scm_debug_opts,
+ SCM_N_DEBUG_OPTIONS,
+ s_debug_options);
+#ifndef SCM_RECKLESS
+ if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
+ {
+ scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, s_debug_options);
+ scm_out_of_range (s_debug_options, setting);
+ }
+#endif
+ SCM_RESET_DEBUG_MODE;
+ scm_debug_eframe_size = 2 * SCM_N_FRAMES;
+ SCM_ALLOW_INTS
+ return ans;
+}
+
+SCM_PROC (s_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, scm_evaluator_traps);
+#ifdef __STDC__
+SCM
+scm_evaluator_traps (SCM setting)
+#else
+SCM
+scm_evaluator_traps (setting)
+ SCM setting;
+#endif
+{
+ SCM ans;
+ SCM_DEFER_INTS;
+ ans = scm_options (setting,
+ scm_evaluator_trap_table,
+ SCM_N_EVALUATOR_TRAPS,
+ s_evaluator_traps);
+ SCM_RESET_DEBUG_MODE;
+ SCM_ALLOW_INTS
+ return ans;
+}
+
+SCM_PROC (s_single_step, "single-step", 2, 0, 0, scm_single_step);
+#ifdef __STDC__
+SCM
+scm_single_step (SCM cont, SCM val)
+#else
+SCM
+scm_single_step (cont, val)
+ SCM cont, SCM val;
+#endif
+{
+ SCM_DEFER_INTS;
+ SCM_ENTER_FRAME_P = SCM_EXIT_FRAME_P = 1;
+ SCM_RESET_DEBUG_MODE;
+ SCM_ALLOW_INTS;
+ scm_throw (cont, val);
+ return SCM_BOOL_F; /* never returns */
+}
+
+
+static SCM scm_i_source, scm_i_more;
+static SCM scm_i_proc, scm_i_args, scm_i_eval_args;
+static SCM scm_i_procname;
+
+/* {Memoized Source}
+ */
+
+long scm_tc16_memoized;
+
+#ifdef __STDC__
+static int
+prinmemoized (SCM obj, SCM port, scm_print_state *pstate)
+#else
+static int
+prinmemoized (obj, port, pstate)
+ SCM obj;
+ SCM port;
+ scm_print_state *pstate;
+#endif
+{
+ int writingp = SCM_WRITINGP (pstate);
+ scm_gen_puts (scm_regular_string, "#<memoized ", port);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (scm_unmemoize (obj), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
+ scm_gen_putc ('>', port);
+ return 1;
+}
+
+static scm_smobfuns memoizedsmob =
+{scm_markcdr, scm_free0, prinmemoized, 0};
+
+SCM_PROC (s_memoized_p, "memoized?", 1, 0, 0, scm_memoized_p);
+#ifdef __STDC__
+SCM
+scm_memoized_p (SCM obj)
+#else
+SCM
+scm_memoized_p (obj)
+ SCM obj;
+#endif
+{
+ return SCM_NIMP (obj) && SCM_MEMOIZEDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+#ifdef __STDC__
+SCM
+scm_make_memoized (SCM exp, SCM env)
+#else
+SCM
+scm_make_memoized (exp, env)
+ SCM exp, SCM env;
+#endif
+{
+ register SCM z, ans;
+ SCM_DEFER_INTS;
+ SCM_NEWCELL (z);
+ SCM_CAR (z) = exp;
+ SCM_CDR (z) = env;
+ SCM_NEWCELL (ans);
+ SCM_CAR (ans) = scm_tc16_memoized;
+ SCM_CDR (ans) = z;
+ SCM_ALLOW_INTS;
+ return ans;
+}
+
+SCM_PROC (s_unmemoize, "unmemoize", 1, 0, 0, scm_unmemoize);
+#ifdef __STDC__
+SCM
+scm_unmemoize (SCM m)
+#else
+SCM
+scm_unmemoize (m)
+ SCM m;
+#endif
+{
+ SCM_ASSERT (SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
+ return scm_unmemocopy (SCM_MEMOEXP (m), SCM_MEMOENV (m));
+}
+
+SCM_PROC (s_memoized_environment, "memoized-environment", 1, 0, 0, scm_memoized_environment);
+#ifdef __STDC__
+SCM
+scm_memoized_environment (SCM m)
+#else
+SCM
+scm_memoized_environment (m)
+ SCM m;
+#endif
+{
+ SCM_ASSERT (SCM_MEMOIZEDP (m), m, SCM_ARG1, s_unmemoize);
+ return SCM_MEMOENV (m);
+}
+
+SCM_PROC (s_procedure_name, "procedure-name", 1, 0, 0, scm_procedure_name);
+#ifdef __STDC__
+SCM
+scm_procedure_name (SCM proc)
+#else
+SCM
+scm_procedure_name (proc)
+ SCM proc;
+#endif
+{
+ SCM_ASSERT(scm_procedure_p (proc) == SCM_BOOL_T,
+ proc,
+ SCM_ARG1,
+ s_procedure_name);
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_closures:
+ {
+ SCM name = scm_procedure_property (proc, scm_i_name);
+#if 0
+ /* Procedure property scm_i_procname not implemented yet... */
+ SCM name = scm_source_property (SCM_CAR (SCM_CDR (SCM_CODE (proc))), scm_i_procname);
+ if (SCM_FALSEP (name))
+ name = scm_procedure_property (proc, scm_i_name);
+#endif
+ return name;
+ }
+ case scm_tcs_subrs:
+ return SCM_SNAME (proc);
+ default:
+ return SCM_BOOL_F;
+ }
+}
+
+SCM_PROC (s_procedure_source, "procedure-source", 1, 0, 0, scm_procedure_source);
+#ifdef __STDC__
+SCM
+scm_procedure_source (SCM proc)
+#else
+SCM
+scm_procedure_source (proc)
+ SCM proc;
+#endif
+{
+ SCM_ASSERT(SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_source);
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_closures:
+ {
+ SCM src;
+ src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_i_copy);
+ if (src != SCM_BOOL_F)
+ return scm_cons2 (scm_i_lambda, SCM_CAR (SCM_CODE (proc)), src);
+ src = SCM_CODE (proc);
+ return scm_cons (scm_i_lambda,
+ scm_unmemocopy (src,
+ SCM_EXTEND_ENV (SCM_CAR (src),
+ SCM_EOL,
+ SCM_ENV (proc))));
+ }
+ case scm_tc7_contin:
+ case scm_tcs_subrs:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+ /* It would indeed be a nice thing if we supplied source even for
+ built in procedures! */
+ return scm_procedure_property (proc, scm_i_source);
+ default:
+ scm_wta (proc, (char *) SCM_ARG1, s_procedure_source);
+ return 0;
+ }
+}
+
+SCM_PROC (s_procedure_environment, "procedure-environment", 1, 0, 0, scm_procedure_environment);
+#ifdef __STDC__
+SCM
+scm_procedure_environment (SCM proc)
+#else
+SCM
+scm_procedure_environment (proc)
+ SCM proc;
+#endif
+{
+ SCM_ASSERT (SCM_NIMP (proc), proc, SCM_ARG1, s_procedure_environment);
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_closures:
+ return SCM_ENV (proc);
+ case scm_tc7_contin:
+ case scm_tcs_subrs:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+ return SCM_EOL;
+ default:
+ scm_wta (proc, (char *) SCM_ARG1, s_procedure_environment);
+ return 0;
+ }
+}
+
+
+/* Eval in a local environment. We would like to have the ability to
+ * evaluate in a specified local environment, but due to the memoization
+ * this isn't normally possible. We solve it by copying the code before
+ * evaluating. Probably the best solution would be to have eval.c generate
+ * yet another evaluator. They are not very big actually.
+ */
+SCM_PROC (s_local_eval, "local-eval", 2, 0, 0, scm_local_eval);
+#ifdef __STDC__
+SCM
+scm_local_eval (SCM exp, SCM env)
+#else
+SCM
+scm_local_eval (exp, env)
+ SCM exp;
+ SCM env;
+#endif
+{
+ return scm_eval_3 (exp, 1, env);
+}
+
+/* {Stack Frames}
+ *
+ * The stack is a list of stackframes, from root to current.
+ *
+ * A stackframe is a list of virtual stackframes, which occur due to
+ * the evaluators tail recursion. A virtual stackframe normally
+ * corresponds to an eval/apply pair, but macros and special forms
+ * (which are implemented as macros in scm...) only have eval
+ * information and apply calls leads to apply only frames.
+ *
+ * A virtual stackframe is either a property list or the symbol
+ * ... which marks the location of virtual stackframes which could not
+ * be stored with the current debug-depth.
+ *
+ * Property Type Description
+ *
+ * These three only present in eval frames:
+ *
+ * sexpr memoized Source code expression and environment.
+ * proc procedure The procedure being applied.
+ * (Not present if pre-apply state.)
+ * args list The arguments evaluated so far.
+ * eval-args boolean True if evaluation of arguments not finished.
+ */
+
+/* {Debug Objects}
+ *
+ * The debugging evaluator throws these on frame traps.
+ */
+
+long scm_tc16_debugobj;
+
+#define DEBUGOBJP(x) (scm_tc16_debugobj == SCM_TYP16 (x))
+#define DBGFRAME(x) SCM_CDR (x)
+
+#ifdef __STDC__
+static int
+prindebugobj (SCM obj, SCM port, scm_print_state *pstate)
+#else
+static int
+prindebugobj (pstate)
+ SCM obj;
+ SCM port;
+ scm_print_state *pstate;
+#endif
+{
+ scm_gen_puts (scm_regular_string, "#<debug-object ", port);
+ scm_intprint (DBGFRAME (obj), 16, port);
+ scm_gen_putc ('>', port);
+ return 1;
+}
+
+static scm_smobfuns debugobjsmob =
+{scm_mark0, scm_free0, prindebugobj, 0};
+
+SCM_PROC (s_debug_object_p, "debug-object?", 1, 0, 0, scm_debug_object_p);
+#ifdef __STDC__
+SCM
+scm_debug_object_p (SCM obj)
+#else
+SCM
+scm_debug_object_p (obj)
+ SCM obj;
+#endif
+{
+ return SCM_NIMP (obj) && DEBUGOBJP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+
+#ifdef __STDC__
+SCM
+scm_make_debugobj (scm_debug_frame *frame)
+#else
+SCM
+scm_make_debugobj (frame)
+ scm_debug_frame *frame;
+#endif
+{
+ register SCM z;
+ SCM_DEFER_INTS;
+ SCM_NEWCELL (z);
+ SCM_CAR (z) = scm_tc16_debugobj;
+ DBGFRAME (z) = (SCM) frame;
+ SCM_ALLOW_INTS;
+ return z;
+}
+
+#ifdef __STDC__
+static SCM
+_scm_stack_frame_to_plist (scm_debug_frame *frame, long offset)
+#else
+static SCM
+_scm_stack_frame_to_plist (frame, offset)
+ scm_debug_frame *frame;
+ long offset;
+#endif
+{
+ int size;
+ scm_debug_info *info;
+ if (SCM_EVALFRAMEP (*frame))
+ {
+ size = frame->status & SCM_MAX_FRAME_SIZE;
+ info = (scm_debug_info *) (*((SCM_STACKITEM **) &frame->vect[size]) + offset);
+ if ((info - frame->vect) & 1)
+ {
+ /* Debug.vect ends with apply info. */
+ SCM p;
+ --info;
+ if (info[1].a.proc == SCM_UNDEFINED)
+ p = SCM_EOL;
+ else
+ p = scm_acons (scm_i_proc,
+ info[1].a.proc,
+ scm_acons (scm_i_args,
+ info[1].a.args,
+ SCM_ARGS_READY_P (*frame)
+ ? SCM_EOL
+ : scm_acons (scm_i_eval_args,
+ SCM_BOOL_T,
+ SCM_EOL)));
+ return scm_acons (scm_i_source,
+ scm_make_memoized (info[0].e.exp, info[0].e.env),
+ p);
+ }
+ else
+ /* Debug.vect ends with eval info. */
+ return scm_acons (scm_i_source,
+ scm_make_memoized (info[0].e.exp, info[0].e.env),
+ SCM_EOL);
+ }
+ else
+ return scm_acons (scm_i_proc,
+ frame->vect[0].a.proc,
+ scm_acons (scm_i_args, frame->vect[0].a.args, SCM_EOL));
+}
+
+SCM_PROC (s_last_stack_frame, "last-stack-frame", 1, 0, 0, scm_last_stack_frame);
+#ifdef __STDC__
+SCM
+scm_last_stack_frame (SCM obj)
+#else
+SCM
+scm_last_stack_frame (obj)
+ SCM obj;
+#endif
+{
+ scm_debug_frame *frame;
+ long offset = 0;
+ SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame);
+ if (scm_tc16_debugobj == SCM_TYP16 (obj))
+ frame = (scm_debug_frame *) DBGFRAME (obj);
+ else if (scm_tc7_contin == SCM_TYP7 (obj))
+ {
+ frame = SCM_DFRAME (obj);
+ offset = (SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (regs)) - SCM_BASE (obj);
+#ifndef STACK_GROWS_UP
+ offset += SCM_LENGTH (obj);
+#endif
+ }
+ else scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame);
+ if (!frame)
+ return SCM_BOOL_F;
+ return _scm_stack_frame_to_plist ((scm_debug_frame *) ((SCM_STACKITEM *) frame + offset), offset);
+}
+
+/* Make a scheme object of the current evaluation stack.
+ */
+
+SCM_PROC (s_expr_stack, "expr-stack", 0, 1, 0, scm_expr_stack);
+#ifdef __STDC__
+SCM
+scm_expr_stack (SCM obj)
+#else
+SCM
+scm_expr_stack (obj)
+ SCM obj;
+#endif
+{
+ SCM frs = SCM_EOL, vfrs, p;
+ int size;
+ int max_vfrs = SCM_BACKTRACE_DEPTH;
+ scm_debug_info *info;
+ scm_debug_frame *frame;
+ long offset = 0;
+ if (SCM_UNBNDP (obj))
+ frame = scm_last_debug_frame;
+ else
+ {
+ SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_expr_stack);
+ if (scm_tc16_debugobj == SCM_TYP16 (obj))
+ frame = (scm_debug_frame *) DBGFRAME (obj);
+ else if (scm_tc7_contin == SCM_TYP7 (obj))
+ {
+ frame = SCM_DFRAME (obj);
+ offset = (SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (regs)) - SCM_BASE (obj);
+#ifndef STACK_GROWS_UP
+ offset += SCM_LENGTH (obj);
+#endif
+ }
+ else scm_wta (obj, (char *) SCM_ARG1, s_expr_stack);
+ }
+ for (; frame && max_vfrs > 0; frame = frame->prev)
+ {
+ frame = (scm_debug_frame *) ((SCM_STACKITEM *) frame + offset);
+ p = _scm_stack_frame_to_plist (frame, offset);
+ if (SCM_EVALFRAMEP (*frame))
+ {
+ size = frame->status & SCM_MAX_FRAME_SIZE;
+ info = (scm_debug_info *) (*((SCM_STACKITEM **) &frame->vect[size]) + offset);
+ vfrs = SCM_EOL;
+ if ((info - frame->vect) & 1)
+ --info;
+ /* Data in the apply part of an eval info frame comes from
+ previous stack frame if the scm_debug_info vector is overflowed. */
+ else if (SCM_OVERFLOWP (*frame)
+ && !SCM_UNBNDP (info[1].a.proc))
+ {
+ vfrs = scm_cons (p, SCM_EOL);
+ --max_vfrs;
+ p = scm_acons (scm_i_proc,
+ info[1].a.proc,
+ scm_acons (scm_i_args, info[1].a.args, SCM_EOL));
+ }
+ info -= 2;
+ vfrs = scm_cons (p, vfrs);
+ --max_vfrs;
+ if (SCM_OVERFLOWP (*frame))
+ vfrs = scm_cons (scm_i_more, vfrs);
+ while (info >= frame->vect)
+ {
+ p = SCM_EOL;
+ if (!SCM_UNBNDP (info[1].a.proc))
+ p = scm_acons (scm_i_proc,
+ info[1].a.proc,
+ scm_acons (scm_i_args, info[1].a.args, SCM_EOL));
+ p = scm_acons (scm_i_source,
+ scm_make_memoized (info[0].e.exp, info[0].e.env),
+ p);
+ info -= 2;
+ vfrs = scm_cons (p, vfrs);
+ --max_vfrs;
+ }
+ }
+ else
+ {
+ vfrs = scm_cons (p, SCM_EOL);
+ --max_vfrs;
+ }
+ frs = scm_cons (vfrs, frs);
+ }
+ if (max_vfrs <= 0)
+ frs = scm_cons (scm_i_more, frs);
+ return frs;
+}
+
+
+
+
+void
+scm_init_debug ()
+{
+ scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
+ scm_init_opts (scm_evaluator_traps,
+ scm_evaluator_trap_table,
+ SCM_N_EVALUATOR_TRAPS);
+
+ scm_tc16_memoized = scm_newsmob (&memoizedsmob);
+ scm_tc16_debugobj = scm_newsmob (&debugobjsmob);
+
+ scm_i_procname = SCM_CAR (scm_sysintern ("procname", SCM_UNDEFINED));
+ scm_i_more = SCM_CAR (scm_sysintern ("...", SCM_UNDEFINED));
+ scm_i_source = SCM_CAR (scm_sysintern ("source", SCM_UNDEFINED));
+ scm_i_proc = SCM_CAR (scm_sysintern ("proc", SCM_UNDEFINED));
+ scm_i_args = SCM_CAR (scm_sysintern ("args", SCM_UNDEFINED));
+ scm_i_eval_args = SCM_CAR (scm_sysintern ("eval-args", SCM_UNDEFINED));
+
+ scm_add_feature ("debug-extensions");
+
+#include "debug.x"
+}
diff --git a/libguile/debug.h b/libguile/debug.h
new file mode 100644
index 000000000..96a4ed0ad
--- /dev/null
+++ b/libguile/debug.h
@@ -0,0 +1,216 @@
+/* classes: h_files */
+
+#ifndef DEBUGH
+#define DEBUGH
+/* Copyright (C) 1995,1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include "libguile/__scm.h"
+
+#include "libguile/options.h"
+
+
+/*
+ * Here comes some definitions for the debugging machinery.
+ * It might seem strange to represent debug flags as ints,
+ * but consider that any particular piece of code is normally
+ * only interested in one flag at a time. This is then
+ * the most efficient representation.
+ */
+
+/* {Options}
+ */
+
+/* scm_debug_opts and scm_evaluator_trap_table are defined in eval.c.
+ */
+
+extern scm_option scm_debug_opts[];
+
+#define SCM_CHEAPTRAPS_P scm_debug_opts[0].val
+#define SCM_BREAKPOINTS_P scm_debug_opts[1].val
+#define SCM_TRACE_P scm_debug_opts[2].val
+#define SCM_REC_PROCNAMES_P scm_debug_opts[3].val
+#define SCM_BACKWARDS_P scm_debug_opts[4].val
+#define SCM_N_FRAMES scm_debug_opts[5].val
+#define SCM_BACKTRACE_DEPTH scm_debug_opts[6].val
+#define SCM_BACKTRACE_P scm_debug_opts[7].val
+#define SCM_DEVAL_P scm_debug_opts[8].val
+#define SCM_STACK_LIMIT scm_debug_opts[9].val
+#define SCM_N_DEBUG_OPTIONS 10
+
+extern scm_option scm_evaluator_trap_table[];
+
+#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[0].val
+#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[1].val
+#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[2].val
+#define SCM_N_EVALUATOR_TRAPS 3
+
+#ifdef __STDC__
+extern SCM (*scm_ceval_ptr) (SCM exp, SCM env);
+#else
+extern SCM (*scm_ceval_ptr) ();
+#endif
+extern int scm_debug_mode;
+extern int scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
+
+#define CHECK_ENTRY scm_check_entry_p
+#define CHECK_APPLY scm_check_apply_p
+#define CHECK_EXIT scm_check_exit_p
+
+#define SCM_RESET_DEBUG_MODE \
+{\
+ if (SCM_ENTER_FRAME_P || SCM_BREAKPOINTS_P) CHECK_ENTRY = 1;\
+ if (SCM_APPLY_FRAME_P || SCM_TRACE_P) CHECK_APPLY = 1;\
+ if (SCM_EXIT_FRAME_P || SCM_TRACE_P) CHECK_EXIT = 1;\
+ scm_debug_mode = SCM_DEVAL_P || SCM_BACKTRACE_P || CHECK_ENTRY || CHECK_APPLY || CHECK_EXIT;\
+ scm_ceval_ptr = scm_debug_mode ? scm_deval : scm_ceval;\
+}
+
+
+/* {Evaluator}
+ */
+
+typedef union scm_debug_info
+{
+ struct { SCM exp, env; } e;
+ struct { SCM proc, args; } a;
+} scm_debug_info;
+
+extern int scm_debug_eframe_size;
+
+typedef struct scm_debug_frame
+{
+ struct scm_debug_frame *prev;
+ long status;
+ scm_debug_info vect[1];
+} scm_debug_frame;
+
+#ifndef USE_THREADS
+extern scm_debug_frame *scm_last_debug_frame;
+#endif
+
+#define SCM_TAILREC (1L << 10)
+#define SCM_TRACED_FRAME (1L << 9)
+#define SCM_APPLYFRAME (1L << 8)
+#define SCM_ARGS_READY (1L << 7)
+#define SCM_DOVERFLOW (1L << 6)
+#define SCM_MAX_FRAME_SIZE 63 /* also used as a mask for the size field */
+
+#define SCM_EVALFRAMEP(x) (((x).status & SCM_APPLYFRAME) == 0)
+#define SCM_APPLYFRAMEP(x) (((x).status & SCM_APPLYFRAME) != 0)
+#define SCM_OVERFLOWP(x) (((x).status & SCM_DOVERFLOW) != 0)
+#define SCM_ARGS_READY_P(x) (((x).status & SCM_ARGS_READY) != 0)
+#define SCM_TRACED_FRAME_P(x) (((x).status & SCM_TRACED_FRAME) != 0)
+#define SCM_TAILRECP(x) (((x).status & SCM_TAILREC) != 0)
+#define SCM_SET_OVERFLOW(x) ((x).status |= SCM_DOVERFLOW)
+#define SCM_SET_ARGSREADY(x) ((x).status |= SCM_ARGS_READY)
+#define SCM_CLEAR_ARGSREADY(x) ((x).status &= ~SCM_ARGS_READY)
+#define SCM_SET_TRACED_FRAME(x) ((x).status |= SCM_TRACED_FRAME)
+#define SCM_CLEAR_TRACED_FRAME(x) ((x).status &= ~SCM_TRACED_FRAME)
+#define SCM_SET_TAILREC(x) ((x).status |= SCM_TAILREC)
+
+#define SCM_DEBUGGINGP scm_debug_mode
+#define SCM_DSIDEVAL(x, env) if NIMP(x) scm_deval((x), (env))
+
+/* {Memoized Source}
+ */
+
+extern long scm_tc16_memoized;
+
+#define SCM_MEMOIZEDP(x) (scm_tc16_memoized == SCM_TYP16 (x))
+#define SCM_MEMOEXP(x) SCM_CAR (SCM_CDR (x))
+#define SCM_MEMOENV(x) SCM_CDR (SCM_CDR (x))
+
+
+
+#ifdef __STDC__
+extern SCM * scm_lookup_cstr (char *str, int len, SCM env);
+extern SCM * scm_lookup_soft (SCM var, SCM genv);
+extern SCM scm_evstr (char *str);
+extern SCM scm_eval_string (SCM str);
+extern int scm_ready_p (void);
+extern void debug_print (SCM obj);
+extern SCM scm_expr_stack (SCM obj);
+extern SCM scm_last_stack_frame (SCM obj);
+extern SCM scm_debug_object_p (SCM obj);
+extern SCM scm_local_eval (SCM exp, SCM env);
+extern SCM scm_procedure_environment (SCM proc);
+extern SCM scm_procedure_source (SCM proc);
+extern SCM scm_procedure_name (SCM proc);
+extern SCM scm_memoized_environment (SCM m);
+extern SCM scm_make_memoized (SCM exp, SCM env);
+extern SCM scm_memoized_p (SCM obj);
+extern SCM scm_single_step (SCM cont, SCM val);
+extern SCM scm_evaluator_traps (SCM setting);
+extern SCM scm_debug_options (SCM setting);
+extern SCM scm_unmemoize (SCM memoized);
+extern SCM scm_make_debugobj (scm_debug_frame* debug);
+extern void scm_init_debug (void);
+#else
+extern SCM * scm_lookup_cstr ();
+extern SCM * scm_lookup_soft ();
+extern SCM scm_evstr ();
+extern SCM scm_eval_string ();
+extern int scm_ready_p ();
+extern void debug_print ();
+extern SCM scm_expr_stack ();
+extern SCM scm_last_stack_frame ();
+extern SCM scm_debug_object_p ();
+extern SCM scm_local_eval ();
+extern SCM scm_procedure_environment ();
+extern SCM scm_procedure_source ();
+extern SCM scm_procedure_name ();
+extern SCM scm_memoized_environment ();
+extern SCM scm_make_memoized ();
+extern SCM scm_memoized_p (SCM obj);
+extern SCM scm_single_step ();
+extern SCM scm_evaluator_traps ();
+extern SCM scm_debug_options ();
+extern SCM scm_unmemoize ();
+extern SCM scm_make_debugobj ();
+extern void scm_init_debug ();
+#endif
+
+#endif /* DEBUGH */
diff --git a/libguile/def.sed b/libguile/def.sed
deleted file mode 100644
index e69de29bb..000000000
--- a/libguile/def.sed
+++ /dev/null
diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index b80a00c76..82ac6d632 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -42,7 +42,10 @@
#include <stdio.h>
#include "_scm.h"
+#include "eval.h"
+#include "alist.h"
+#include "dynwind.h"
/* {Dynamic wind}
diff --git a/libguile/dynwind.h b/libguile/dynwind.h
index 42f1515d2..bed5231d5 100644
--- a/libguile/dynwind.h
+++ b/libguile/dynwind.h
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
#ifdef __STDC__
diff --git a/libguile/eq.c b/libguile/eq.c
index ed6dc4e12..bf4473ec1 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -41,7 +41,13 @@
#include <stdio.h>
#include "_scm.h"
+#include "ramap.h"
+#include "stackchk.h"
+#include "strorder.h"
+#include "smob.h"
+#include "unif.h"
+#include "eq.h"
SCM_PROC1 (s_eq_p, "eq?", scm_tc7_rpsubr, scm_eq_p);
#ifdef __STDC__
diff --git a/libguile/eq.h b/libguile/eq.h
index db164ec0d..e160b4ad6 100644
--- a/libguile/eq.h
+++ b/libguile/eq.h
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-
+#include "libguile/__scm.h"
#ifdef __STDC__
diff --git a/libguile/error.c b/libguile/error.c
index c16612513..304d74484 100644
--- a/libguile/error.c
+++ b/libguile/error.c
@@ -42,30 +42,32 @@
#include <stdio.h>
#include "_scm.h"
+#include "pairs.h"
+#include "genio.h"
+#include "throw.h"
+#include "error.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
/* {Errors and Exceptional Conditions}
*/
-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))
@@ -74,7 +76,7 @@ err_head (str)
#if 0
if (SCM_BOOL_F != *scm_loc_loadpath)
{
- scm_iprin1 (*scm_loc_loadpath, scm_cur_errp, 1);
+ scm_prin1 (*scm_loc_loadpath, scm_cur_errp, 1);
scm_gen_puts (scm_regular_string, ", line ", scm_cur_errp);
scm_intprint ((long) scm_linum, 10, scm_cur_errp);
scm_gen_puts (scm_regular_string, ": ", scm_cur_errp);
@@ -93,14 +95,9 @@ err_head (str)
SCM_PROC(s_errno, "errno", 0, 1, 0, scm_errno);
-#ifdef __STDC__
-SCM
-scm_errno (SCM arg)
-#else
-SCM
+SCM
scm_errno (arg)
SCM arg;
-#endif
{
int old = errno;
if (!SCM_UNBNDP (arg))
@@ -114,92 +111,236 @@ scm_errno (arg)
}
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;
}
+void (*scm_error_callback) () = 0;
-#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
+/* all errors thrown from C should pass through here. */
+/* also known as scm_error. */
+void
+scm_error (key, subr, message, args, rest)
+ SCM key;
+ char *subr;
+ char *message;
+ SCM args;
+ SCM rest;
{
- 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);
+ SCM arg_list;
+ if (scm_error_callback)
+ (*scm_error_callback) (key, subr, message, args, rest);
+
+ arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F,
+ message ? scm_makfrom0str (message) : SCM_BOOL_F,
+ args,
+ rest,
+ SCM_UNDEFINED);
+ scm_ithrow (key, arg_list, 1);
/* No return, but just in case: */
- write (2, "unhandled system error", sizeof ("unhandled system error"));
+ write (2, "unhandled system error", sizeof ("unhandled system error") - 1);
exit (1);
}
-#ifdef __STDC__
-SCM
-scm_wta (SCM arg, char *pos, char *s_subr)
+/* error keys: defined here, initialized below, prototyped in error.h,
+ associated with handler procedures in boot-9.scm. */
+SCM scm_system_error_key;
+SCM scm_num_overflow_key;
+SCM scm_out_of_range_key;
+SCM scm_arg_type_key;
+SCM scm_args_number_key;
+SCM scm_memory_alloc_key;
+SCM scm_stack_overflow_key;
+SCM scm_misc_error_key;
+
+void
+scm_syserror (subr)
+ char *subr;
+{
+ scm_error (scm_system_error_key,
+ subr,
+ "%s",
+ scm_listify (scm_makfrom0str (strerror (errno)),
+ SCM_UNDEFINED),
+ scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
+}
+
+void
+scm_syserror_msg (subr, message, args)
+ char *subr;
+ char *message;
+ SCM args;
+{
+ scm_error (scm_system_error_key,
+ subr,
+ message,
+ args,
+ scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
+}
+
+void
+scm_sysmissing (subr)
+ char *subr;
+{
+#ifdef ENOSYS
+ scm_error (scm_system_error_key,
+ subr,
+ "%s",
+ scm_listify (scm_makfrom0str (strerror (ENOSYS)), SCM_UNDEFINED),
+ scm_listify (SCM_MAKINUM (ENOSYS), SCM_UNDEFINED));
#else
+ scm_error (scm_system_error_key,
+ subr,
+ "Missing function",
+ SCM_BOOL_F,
+ scm_listify (SCM_MAKINUM (0), SCM_UNDEFINED));
+#endif
+}
+
+void
+scm_num_overflow (subr)
+ char *subr;
+{
+ scm_error (scm_num_overflow_key,
+ subr,
+ "Numerical overflow",
+ SCM_BOOL_F,
+ SCM_BOOL_F);
+}
+
+void
+scm_out_of_range (subr, bad_value)
+ char *subr;
+ SCM bad_value;
+{
+ scm_error (scm_out_of_range_key,
+ subr,
+ "Argument out of range: %S",
+ scm_listify (bad_value, SCM_UNDEFINED),
+ SCM_BOOL_F);
+}
+
+void
+scm_wrong_num_args (proc)
+ SCM proc;
+{
+ scm_error (scm_args_number_key,
+ NULL,
+ "Wrong number of arguments to %s",
+ scm_listify (proc, SCM_UNDEFINED),
+ SCM_BOOL_F);
+}
+
+void
+scm_wrong_type_arg (subr, pos, bad_value)
+ char *subr;
+ int pos;
+ SCM bad_value;
+{
+ scm_error (scm_arg_type_key,
+ subr,
+ (pos == 0) ? "Wrong type argument: %S"
+ : "Wrong type argument in position %s: %S",
+ (pos == 0) ? scm_listify (bad_value, SCM_UNDEFINED)
+ : scm_listify (SCM_MAKINUM (pos), bad_value, SCM_UNDEFINED),
+ SCM_BOOL_F);
+}
+
+void
+scm_memory_error (subr)
+ char *subr;
+{
+ scm_error (scm_memory_alloc_key,
+ subr,
+ "Memory allocation error",
+ SCM_BOOL_F,
+ SCM_BOOL_F);
+}
+
+/* implements the SCM_ASSERT interface. */
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);
+ if (!s_subr || !*s_subr)
+ s_subr = NULL;
+ if ((~0x1fL) & (long) pos)
+ {
+ /* error string supplied. */
+ scm_error (scm_misc_error_key,
+ s_subr,
+ pos,
+ SCM_BOOL_F,
+ SCM_BOOL_F);
+ }
+ else
+ {
+ /* numerical error code. */
+ int error = (long) pos;
+
+ switch (error)
+ {
+ case SCM_ARGn:
+ scm_wrong_type_arg (s_subr, 0, arg);
+ case SCM_ARG1:
+ scm_wrong_type_arg (s_subr, 1, arg);
+ case SCM_ARG2:
+ scm_wrong_type_arg (s_subr, 2, arg);
+ case SCM_ARG3:
+ scm_wrong_type_arg (s_subr, 3, arg);
+ case SCM_ARG4:
+ scm_wrong_type_arg (s_subr, 4, arg);
+ case SCM_ARG5:
+ scm_wrong_type_arg (s_subr, 5, arg);
+ case SCM_WNA:
+ scm_wrong_num_args (arg);
+ case SCM_OUTOFRANGE:
+ scm_out_of_range (s_subr, arg);
+ case SCM_NALLOC:
+ scm_memory_error (s_subr);
+ default:
+ /* this shouldn't happen. */
+ scm_error (scm_misc_error_key,
+ s_subr,
+ "Unknown error",
+ SCM_BOOL_F,
+ SCM_BOOL_F);
+ }
+ }
return SCM_UNSPECIFIED;
}
+/* obsolete interface: scm_everr (exp, env, arg, pos, s_subr)
+ was equivalent to scm_wta (arg, pos, s_subr) */
-
-#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);
+ scm_system_error_key
+ = scm_permanent_object (SCM_CAR (scm_intern0 ("system-error")));
+ scm_num_overflow_key
+ = scm_permanent_object (SCM_CAR (scm_intern0 ("numerical-overflow")));
+ scm_out_of_range_key
+ = scm_permanent_object (SCM_CAR (scm_intern0 ("out-of-range")));
+ scm_arg_type_key
+ = scm_permanent_object (SCM_CAR (scm_intern0 ("wrong-type-arg")));
+ scm_args_number_key
+ = scm_permanent_object (SCM_CAR (scm_intern0 ("wrong-number-of-args")));
+ scm_memory_alloc_key
+ = scm_permanent_object (SCM_CAR (scm_intern0 ("memory-allocation-error")));
+ scm_stack_overflow_key
+ = scm_permanent_object (SCM_CAR (scm_intern0 ("stack-overflow")));
+ scm_misc_error_key
+ = scm_permanent_object (SCM_CAR (scm_intern0 ("misc-error")));
#include "error.x"
}
diff --git a/libguile/error.h b/libguile/error.h
index c635c5d13..68ddfcdad 100644
--- a/libguile/error.h
+++ b/libguile/error.h
@@ -43,37 +43,37 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
-#include "pairs.h"
+#include "libguile/__scm.h"
-
extern int scm_ints_disabled;
-extern SCM system_error_sym;
-
-
+extern SCM scm_system_error_key;
+extern SCM scm_num_overflow_key;
+extern SCM scm_out_of_range_key;
+extern SCM scm_arg_type_key;
+extern SCM scm_args_number_key;
+extern SCM scm_memory_alloc_key;
+extern SCM scm_stack_overflow_key;
+extern SCM scm_misc_error_key;
-#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 */
+extern SCM scm_errno SCM_P ((SCM arg));
+extern SCM scm_perror SCM_P ((SCM arg));
+extern void scm_error SCM_P ((SCM key, char *subr, char *message,
+ SCM args, SCM rest));
+extern void (*scm_error_callback) SCM_P ((SCM key, char *subr,
+ char *message, SCM args, SCM rest));
+extern void scm_syserror SCM_P ((char *subr));
+extern void scm_syserror_msg SCM_P ((char *subr, char *message, SCM args));
+extern void scm_sysmissing SCM_P ((char *subr));
+extern void scm_num_overflow SCM_P ((char *subr));
+extern void scm_out_of_range SCM_P ((char *subr, SCM bad_value));
+extern void scm_wrong_num_args SCM_P ((SCM proc));
+extern void scm_wrong_type_arg SCM_P ((char *subr, int pos, SCM bad_value));
+extern void scm_memory_error SCM_P ((char *subr));
+extern SCM scm_wta SCM_P ((SCM arg, char *pos, char *s_subr));
+extern void scm_init_error SCM_P ((void));
#endif /* ERRORH */
diff --git a/libguile/eval.c b/libguile/eval.c
index 7b2f3600e..e458ada9f 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -40,36 +40,99 @@
*/
-/* 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.
+/* This file is read twice in order to produce debugging versions of
+ * scm_ceval and scm_apply. These functions, scm_deval and
+ * scm_dapply, are produced when we define the preprocessor macro
+ * DEVAL. The file is divided into sections which are treated
+ * differently with respect to DEVAL. The heads of these sections are
+ * marked with the string "SECTION:".
+ */
+
+
+/* SECTION: This code is compiled once.
*/
#ifndef DEVAL
#include <stdio.h>
#include "_scm.h"
+#include "debug.h"
+#include "append.h"
+#include "alist.h"
+#include "sequences.h"
+#include "eq.h"
+#include "continuations.h"
+#include "throw.h"
+#include "smob.h"
+#include "markers.h"
+#include "procprop.h"
+#include "hashtab.h"
+#include "hash.h"
+
+#ifdef DEBUG_EXTENSIONS
+#include "debug.h"
+#endif /* DEBUG_EXTENSIONS */
+
+#include "srcprop.h"
+#include "stackchk.h"
+#include "eval.h"
+/* The evaluator contains a plethora of EVAL symbols.
+ * This is an attempt at explanation.
+ *
+ * The following macros should be used in code which is read twice
+ * (where the choice of evaluator is hard soldered):
+ *
+ * SCM_CEVAL is the symbol used within one evaluator to call itself.
+ * Originally, it is defined to scm_ceval, but is redefined to
+ * scm_deval during the second pass.
+ *
+ * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where
+ * only side effects of expressions matter. All immediates are
+ * ignored.
+ *
+ * EVALIM is used when it is known that the expression is an
+ * immediate. (This macro never calls an evaluator.)
+ *
+ * EVALCAR evaluates the car of an expression.
+ *
+ * EVALCELLCAR is like EVALCAR, but is used when it is known that the
+ * car is a lisp cell.
+ *
+ * The following macros should be used in code which is read once
+ * (where the choice of evaluator is dynamic):
+ *
+ * XEVAL takes care of immediates without calling an evaluator. It
+ * then calls scm_ceval *or* scm_deval, depending on the debugging
+ * mode.
+ *
+ * XEVALCAR corresponds to EVALCAR, but uses scm_ceval *or* scm_deval
+ * depending on the debugging mode.
+ *
+ * The main motivation for keeping this plethora is efficiency
+ * together with maintainability (=> locality of code).
+ */
+
#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)
+#define EVALIM(x, env) (SCM_ILOCP(x)?*scm_ilookup((x), env):x)
#else
-#define EVALIMP(x, env) x
+#define EVALIM(x, env) x
#endif
#define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
? (SCM_IMP(SCM_CAR(x)) \
- ? EVALIMP(SCM_CAR(x), env) \
+ ? EVALIM(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) \
+ ? EVALIM(SCM_CAR(x), env) \
: SCM_GLOC_VAL(SCM_CAR(x))) \
: (SCM_SYMBOLP(SCM_CAR(x)) \
? *scm_lookupcar(x, env) \
@@ -78,7 +141,7 @@
#define XEVALCAR(x, env) EVALCAR(x, env)
#endif
-#define EXTEND_SCM_ENV SCM_EXTEND_SCM_ENV
+#define EXTEND_ENV SCM_EXTEND_ENV
#ifdef MEMOIZE_LOCALS
#ifdef __STDC__
@@ -179,11 +242,14 @@ scm_lookupcar (vloc, genv)
{
var = SCM_CAR (var);
errout:
- scm_everr (vloc, genv, var,
- (SCM_NULLP (env)
- ? "unbound variable: "
- : "damaged environment"),
- "");
+ /* scm_everr (vloc, genv,...) */
+ scm_error (scm_misc_error_key,
+ NULL,
+ SCM_NULLP (env)
+ ? "Unbound variable: %S"
+ : "Damaged environment: %S",
+ scm_listify (var, SCM_UNDEFINED),
+ SCM_BOOL_F);
}
#endif
SCM_CAR (vloc) = var + 1;
@@ -204,7 +270,9 @@ scm_unmemocar (form, env)
SCM env;
#endif
{
+#ifdef DEBUG_EXTENSIONS
register int ir;
+#endif
SCM c;
if (SCM_IMP (form))
@@ -213,6 +281,7 @@ scm_unmemocar (form, env)
if (1 == (c & 7))
SCM_CAR (form) = SCM_CAR (c - 1);
#ifdef MEMOIZE_LOCALS
+#ifdef DEBUG_EXTENSIONS
else if (SCM_ILOCP (c))
{
for (ir = SCM_IFRAME (c); ir != 0; --ir)
@@ -223,6 +292,7 @@ scm_unmemocar (form, env)
SCM_CAR (form) = SCM_ICDRP (c) ? env : SCM_CAR (env);
}
#endif
+#endif
return form;
}
@@ -236,7 +306,7 @@ scm_eval_car (pair, env)
SCM env;
#endif
{
- return EVALCAR (pair, env);
+ return XEVALCAR (pair, env);
}
@@ -257,11 +327,16 @@ static char s_formals[] = "bad formals";
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
+SCM scm_i_define, scm_i_and, scm_i_begin, scm_i_case, scm_i_cond,
+ scm_i_do, scm_i_if, scm_i_let, scm_i_letrec, scm_i_letstar,
+ scm_i_or, scm_i_set, scm_i_atapply, scm_i_atcall_cc;
static char s_quasiquote[] = "quasiquote";
static char s_delay[] = "delay";
+static char s_undefine[] = "undefine";
+#ifdef DEBUG_EXTENSIONS
+SCM scm_i_enter_frame, scm_i_apply_frame, scm_i_exit_frame;
+SCM scm_i_trace;
+#endif
#define ASRTSYNTAX(cond_, msg_) if(!(cond_))scm_wta(xorig, (msg_), what);
@@ -337,24 +412,10 @@ scm_m_set (xorig, env)
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;
- }
- }
+ SCM x = SCM_CDR (xorig);
+ ASSYNT (2 == scm_ilength (x), xorig, s_expression, "set!");
+ ASSYNT (SCM_NIMP (SCM_CAR (x)) && SCM_SYMBOLP (SCM_CAR (x)),
+ xorig, s_variable, "set!");
return scm_cons (SCM_IM_SET, x);
}
@@ -374,8 +435,12 @@ scm_m_vref (xorig, env)
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");
+ /* scm_everr (SCM_UNDEFINED, env,..., "global variable reference") */
+ scm_error (scm_misc_error_key,
+ NULL,
+ "Bad variable: %S",
+ scm_listify (SCM_CAR (SCM_CDR (x)), SCM_UNDEFINED),
+ SCM_BOOL_F);
}
ASSYNT (SCM_NIMP(x) && DEFSCM_VARIABLEP (SCM_CAR (x)),
xorig, s_variable, s_vref);
@@ -556,8 +621,7 @@ scm_m_letstar (xorig, env)
ASSYNT (len >= 2, xorig, s_body, "let*");
proc = SCM_CAR (x);
ASSYNT (scm_ilength (proc) >= 0, xorig, s_bindings, "let*");
- while SCM_NIMP
- (proc)
+ while SCM_NIMP (proc)
{
arg1 = SCM_CAR (proc);
ASSYNT (2 == scm_ilength (arg1), xorig, s_bindings, "let*");
@@ -628,19 +692,10 @@ scm_m_do (xorig, env)
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);
-}
+/* evalcar is small version of inline EVALCAR when we don't care about
+ * speed
+ */
+#define evalcar scm_eval_car
#ifdef __STDC__
static SCM
@@ -772,6 +827,10 @@ scm_m_define (x, env)
if (SCM_TOP_LEVEL (env))
{
x = evalcar (x, env);
+#ifdef DEBUG_EXTENSIONS
+ if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x))
+ scm_set_procedure_property_x (x, scm_i_name, proc);
+#endif
arg1 = scm_sym2vcell (proc, env_top_level (env), SCM_BOOL_T);
#if 0
#ifndef RECKLESS
@@ -783,10 +842,6 @@ scm_m_define (x, env)
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);
@@ -796,6 +851,38 @@ scm_m_define (x, env)
}
return scm_cons2 (SCM_IM_DEFINE, proc, x);
}
+
+SCM
+scm_m_undefine (x, env)
+ SCM x, env;
+{
+ SCM arg1 = x;
+ x = SCM_CDR (x);
+ ASSYNT (SCM_TOP_LEVEL (env), arg1, "bad placement ", s_undefine);
+ ASSYNT (SCM_NIMP (x) && SCM_CONSP (x) && SCM_CDR (x) == SCM_EOL,
+ arg1, s_expression, s_undefine);
+ x = SCM_CAR (x);
+ ASSYNT (SCM_NIMP (x) && SCM_SYMBOLP (x), arg1, s_variable, s_undefine);
+ arg1 = scm_sym2vcell (x, env_top_level (env), SCM_BOOL_F);
+ ASSYNT (SCM_NFALSEP (arg1) && !SCM_UNBNDP (SCM_CDR (arg1)),
+ x, "variable already unbound ", s_undefine);
+#if 0
+#ifndef RECKLESS
+ if (SCM_NIMP (SCM_CDR (arg1)) && ((SCM) SCM_SNAME (SCM_CDR (arg1)) == x))
+ scm_warn ("undefining built-in ", SCM_CHARS (x));
+ else
+#endif
+ if (5 <= scm_verbose && SCM_UNDEFINED != SCM_CDR (arg1))
+ scm_warn ("redefining ", SCM_CHARS (x));
+#endif
+ SCM_CDR (arg1) = SCM_UNDEFINED;
+#ifdef SICP
+ return SCM_CAR (arg1);
+#else
+ return SCM_UNSPECIFIED;
+#endif
+}
+
/* end of acros */
#ifdef __STDC__
@@ -899,7 +986,7 @@ scm_m_apply (xorig, env)
return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
}
-#define s_atcall_cc (SCM_ISYMSCM_CHARS(SCM_IM_CONT)+1)
+#define s_atcall_cc (SCM_ISYMCHARS(SCM_IM_CONT)+1)
#ifdef __STDC__
SCM
@@ -915,6 +1002,209 @@ scm_m_cont (xorig, env)
return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
}
+/* scm_unmemocopy takes a memoized expression together with its
+ * environment and rewrites it to its original form. Thus, it is the
+ * inversion of the rewrite rules above. The procedure is not
+ * optimized for speed. It's used in scm_iprin1 when printing the
+ * code of a closure, in scm_procedure_source and in scm_expr_stack
+ * when generating the source for a stackframe.
+ */
+
+#ifdef __STDC__
+static SCM
+unmemocopy (SCM x, SCM env)
+#else
+static SCM
+unmemocopy (x, env)
+ SCM x;
+ SCM env;
+#endif
+{
+ SCM ls, z;
+#ifdef DEBUG_EXTENSIONS
+ SCM p;
+#endif
+ if (SCM_NCELLP (x) || SCM_NECONSP (x))
+ return x;
+#ifdef DEBUG_EXTENSIONS
+ p = scm_whash_lookup (scm_source_whash, x);
+#endif
+ switch (SCM_TYP7 (x))
+ {
+ case (127 & SCM_IM_AND):
+ ls = z = scm_cons (scm_i_and, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_BEGIN):
+ ls = z = scm_cons (scm_i_begin, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_CASE):
+ ls = z = scm_cons (scm_i_case, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_COND):
+ ls = z = scm_cons (scm_i_cond, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_DO):
+ ls = scm_cons (scm_i_do, SCM_UNSPECIFIED);
+ goto transform;
+ case (127 & SCM_IM_IF):
+ ls = z = scm_cons (scm_i_if, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_LET):
+ ls = scm_cons (scm_i_let, SCM_UNSPECIFIED);
+ goto transform;
+ case (127 & SCM_IM_LETREC):
+ {
+ SCM f, v, e, s;
+ ls = scm_cons (scm_i_letrec, SCM_UNSPECIFIED);
+ transform:
+ x = SCM_CDR (x);
+ f = v = SCM_CAR (x);
+ x = SCM_CDR (x);
+ z = EXTEND_ENV (f, SCM_EOL, env);
+ e = scm_reverse (unmemocopy (SCM_CAR (x),
+ SCM_CAR (ls) == scm_i_letrec ? z : env));
+ env = z;
+ s = SCM_CAR (ls) == scm_i_do
+ ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env))
+ : f;
+ z = SCM_EOL;
+ do
+ {
+ z = scm_acons (SCM_CAR (v),
+ scm_cons (SCM_CAR (e),
+ SCM_CAR (s) == SCM_CAR (v)
+ ? SCM_EOL
+ : scm_cons (SCM_CAR (s), SCM_EOL)),
+ z);
+ v = SCM_CDR (v);
+ e = SCM_CDR (e);
+ s = SCM_CDR (s);
+ }
+ while SCM_NIMP (v);
+ SCM_CDR (ls) = z = scm_cons (z, SCM_UNSPECIFIED);
+ if (SCM_CAR (ls) == scm_i_do)
+ {
+ x = SCM_CDR (x);
+ z = (SCM_CDR (z) = scm_cons (unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED));
+ x = (SCM) (&SCM_CAR (SCM_CDR (x)) - 1);
+ }
+ break;
+ }
+ case (127 & SCM_IM_LETSTAR):
+ {
+ SCM b, y;
+ x = SCM_CDR (x);
+ b = SCM_CAR (x);
+ y = SCM_EOL;
+ if SCM_IMP (b)
+ {
+ env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ goto letstar;
+ }
+ y = z = scm_acons (SCM_CAR (b),
+ unmemocar (
+ scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
+ SCM_UNSPECIFIED);
+ env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDR (SCM_CDR (b));
+ if (SCM_IMP (b))
+ {
+ SCM_SETCDR (y, SCM_EOL);
+ ls = scm_cons (scm_i_let, z = scm_cons (y, SCM_UNSPECIFIED));
+ break;
+ }
+ do
+ {
+ z = (SCM_CDR (z) = scm_acons (SCM_CAR (b),
+ unmemocar (
+ scm_cons (unmemocopy (SCM_CAR (SCM_CDR (b)), env), SCM_EOL), env),
+ SCM_UNSPECIFIED));
+ env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
+ b = SCM_CDR (SCM_CDR (b));
+ }
+ while SCM_NIMP (b);
+ SCM_CDR (z) = SCM_EOL;
+ letstar:
+ ls = scm_cons (scm_i_letstar, z = scm_cons (y, SCM_UNSPECIFIED));
+ break;
+ }
+ case (127 & SCM_IM_OR):
+ ls = z = scm_cons (scm_i_or, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_LAMBDA):
+ x = SCM_CDR (x);
+ ls = scm_cons (scm_i_lambda,
+ z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED));
+ env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
+ break;
+ case (127 & SCM_IM_QUOTE):
+ ls = z = scm_cons (scm_i_quote, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_SET):
+ ls = z = scm_cons (scm_i_set, SCM_UNSPECIFIED);
+ break;
+ case (127 & SCM_IM_DEFINE):
+ {
+ SCM n;
+ x = SCM_CDR (x);
+ ls = scm_cons (scm_i_define,
+ z = scm_cons (n = SCM_CAR (x), SCM_UNSPECIFIED));
+ if (SCM_NNULLP (env))
+ SCM_CAR (SCM_CAR (env)) = scm_cons (n, SCM_CAR (SCM_CAR (env)));
+ break;
+ }
+ case (127 & SCM_MAKISYM (0)):
+ z = SCM_CAR (x);
+ if (!SCM_ISYMP (z))
+ goto unmemo;
+ switch SCM_ISYMNUM (z)
+ {
+ case (SCM_ISYMNUM (SCM_IM_APPLY)):
+ ls = z = scm_cons (scm_i_atapply, SCM_UNSPECIFIED);
+ goto loop;
+ case (SCM_ISYMNUM (SCM_IM_CONT)):
+ ls = z = scm_cons (scm_i_atcall_cc, SCM_UNSPECIFIED);
+ goto loop;
+ default:
+ }
+ unmemo:
+ default:
+ ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED),
+ env);
+ }
+loop:
+ while (SCM_CELLP (x = SCM_CDR (x)) && SCM_ECONSP (x))
+ z = (SCM_CDR (z) = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env),
+ SCM_UNSPECIFIED),
+ env));
+ SCM_CDR (z) = x;
+#ifdef DEBUG_EXTENSIONS
+ if (SCM_NFALSEP (p))
+ scm_whash_insert (scm_source_whash, ls, p);
+#endif
+ return ls;
+}
+
+#ifdef __STDC__
+SCM
+scm_unmemocopy (SCM x, SCM env)
+#else
+SCM
+scm_unmemocopy (x, env)
+ SCM x;
+ SCM env;
+#endif
+{
+ if (SCM_NNULLP (env))
+ /* Make a copy of the lowest frame to protect it from
+ modifications by SCM_IM_DEFINE */
+ return unmemocopy (x, scm_cons (SCM_CAR (env), SCM_CDR (env)));
+ else
+ return unmemocopy (x, env);
+}
+
#ifndef RECKLESS
#ifdef __STDC__
int
@@ -944,36 +1234,172 @@ scm_badargsp (formals, args)
long scm_tc16_macro;
+#ifdef __STDC__
+SCM
+scm_eval_args (SCM l, SCM env)
+#else
+SCM
+scm_eval_args (l, env)
+ SCM l;
+ SCM env;
+#endif
+{
+ 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;
+}
#endif /* !DEVAL */
-#ifdef DEVAL
-#undef SCM_EVAL_ARGS
-#define SCM_EVAL_ARGS scm_deval_args
+
+/* SECTION: This code is specific for the debugging support. One
+ * branch is read when DEVAL isn't defined, the other when DEVAL is
+ * defined.
+ */
+
+#ifndef DEVAL
+
+#define SCM_APPLY scm_apply
+#define PREP_APPLY(proc, args)
+#define ENTER_APPLY
+#define RETURN(x) return x;
+#ifdef STACK_CHECKING
+#ifndef NO_CEVAL_STACK_CHECKING
+#define EVAL_STACK_CHECKING
+#endif
+#endif
+
+#else /* !DEVAL */
+
#undef SCM_CEVAL
#define SCM_CEVAL scm_deval /* Substitute all uses of scm_ceval */
#undef SCM_APPLY
#define SCM_APPLY scm_dapply
+#undef PREP_APPLY
+#define PREP_APPLY(p, l) \
+{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
+#undef ENTER_APPLY
+#define ENTER_APPLY \
+{\
+ SCM_SET_ARGSREADY (debug);\
+ if (CHECK_APPLY)\
+ if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
+ {\
+ SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
+ SCM_SET_TRACED_FRAME (debug);\
+ if (SCM_CHEAPTRAPS_P)\
+ {\
+ tmp = scm_make_debugobj ((scm_debug_frame *) &debug);\
+ scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
+ }\
+ else\
+ {\
+ scm_make_cont (&tmp);\
+ if (!setjmp (SCM_JMPBUF (tmp)))\
+ scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
+ }\
+ }\
+}
#undef RETURN
#define RETURN(e) {proc = (e); goto exit;}
+#ifdef STACK_CHECKING
+#ifndef EVAL_STACK_CHECKING
+#define EVAL_STACK_CHECKING
+#endif
+#endif
+
+/* scm_ceval_ptr points to the currently selected evaluator.
+ * *fixme*: Although efficiency is important here, this state variable
+ * should probably not be a global. It should be related to the
+ * current repl.
+ */
+
+#ifdef __STDC__
+SCM (*scm_ceval_ptr) (SCM exp, SCM env);
#else
-#define SCM_EVAL_ARGS scm_eval_args
-#define RETURN(x) return x;
+SCM (*scm_ceval_ptr) ();
#endif
-SCM
-SCM_EVAL_ARGS (l, env)
- SCM l, env;
+/* scm_last_debug_frame contains a pointer to the last debugging
+ * information stack frame. It is accessed very often from the
+ * debugging evaluator, so it should probably not be indirectly
+ * addressed. Better to save and restore it from the current root at
+ * any stack swaps.
+ */
+
+#ifndef USE_THREADS
+scm_debug_frame *scm_last_debug_frame;
+#endif
+
+/* scm_debug_eframe_size is the number of slots available for pseudo
+ * stack frames at each real stack frame.
+ */
+
+int scm_debug_eframe_size;
+
+int scm_debug_mode, scm_check_entry_p, scm_check_apply_p, scm_check_exit_p;
+
+scm_option scm_debug_opts[] = {
+ { SCM_OPTION_BOOLEAN, "cheap", 1,
+ "*Flyweight representation of the stack at traps." },
+ { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
+ { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
+ { SCM_OPTION_BOOLEAN, "procnames", 1,
+ "Record procedure names at definition." },
+ { SCM_OPTION_BOOLEAN, "backwards", 0,
+ "Display backtrace in anti-chronological order." },
+ { SCM_OPTION_INTEGER, "frames", 2,
+ "Maximum number of tail-recursive frames in backtrace." },
+ { SCM_OPTION_INTEGER, "depth", 80, "Maximal length of backtrace." },
+ { SCM_OPTION_BOOLEAN, "backtrace", 0,
+ "Show backtrace on error (use debugging evaluator)." },
+ { SCM_OPTION_BOOLEAN, "deval", 0, "Use the debugging evaluator." },
+ { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (0 = no check)." }
+};
+
+scm_option scm_evaluator_trap_table[] = {
+ { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
+ { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
+ { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." }
+};
+
+SCM
+scm_deval_args (l, env, lloc)
+ SCM l, env, *lloc;
{
- SCM res = SCM_EOL, *lloc = &res;
+ SCM *res = lloc;
while (SCM_NIMP (l))
{
*lloc = scm_cons (EVALCAR (l, env), SCM_EOL);
lloc = &SCM_CDR (*lloc);
l = SCM_CDR (l);
}
- return res;
+ return *res;
}
+#endif /* !DEVAL */
+
+
+/* SECTION: Some local definitions for the evaluator.
+ */
+
+#ifndef DEVAL
+#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
+#endif /* DEVAL */
+
+
+/* SECTION: This is the evaluator. Like any real monster, it has
+ * three heads. This code is compiled twice.
+ */
+
#if 0
#ifdef __STDC__
SCM
@@ -999,31 +1425,112 @@ scm_deval (x, env)
{}
#endif
-#ifdef SCM_FLOATS
-#define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
+#ifdef __STDC__
+SCM
+SCM_CEVAL (SCM x, SCM env)
#else
-#define CHECK_EQVISH(A,B) ((A) == (B))
-#endif
-
-
-SCM
+SCM
SCM_CEVAL (x, env)
SCM x;
SCM env;
+#endif
{
union
{
SCM *lloc;
SCM arg1;
} t;
- SCM proc;
- SCM arg2;
-
- SCM_CHECK_STACK;
-
- loop:
+ SCM proc, arg2;
+#ifdef DEVAL
+ struct
+ {
+ scm_debug_frame *prev;
+ long status;
+ scm_debug_info vect[scm_debug_eframe_size];
+ scm_debug_info *info;
+ } debug;
+ debug.prev = scm_last_debug_frame;
+ debug.status = scm_debug_eframe_size;
+ debug.info = &debug.vect[0];
+ scm_last_debug_frame = (scm_debug_frame *) &debug;
+#endif
+#ifdef EVAL_STACK_CHECKING
+ if (SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc)
+ && scm_stack_checking_enabled_p)
+ {
+#ifdef DEVAL
+ debug.info->e.exp = x;
+ debug.info->e.env = env;
+#endif
+ scm_report_stack_overflow ();
+ }
+#endif
+#ifdef DEVAL
+ goto start;
+#endif
+loopnoap:
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+loop:
+#ifdef DEVAL
+#if 0 /* This will probably never have any practical use ... */
+ if (CHECK_EXIT)
+ {
+ if (SINGLE_STEP || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
+ {
+ SINGLE_STEP = 0;
+ SCM_RESET_DEBUG_MODE;
+ SCM_CLEAR_TRACED_FRAME (debug);
+ scm_make_cont (&t.arg1);
+ if (!setjmp (SCM_JMPBUF (t.arg1)))
+ scm_ithrow (scm_i_exit_tail, scm_cons (t.arg1, SCM_EOL), 0);
+ }
+ }
+nextframe:
+#endif
+ SCM_CLEAR_ARGSREADY (debug);
+ if (SCM_OVERFLOWP (debug))
+ --debug.info;
+ else if (++debug.info == (scm_debug_info *) &debug.info)
+ {
+ SCM_SET_OVERFLOW (debug);
+ debug.info -= 2;
+ }
+start:
+ debug.info->e.exp = x;
+ debug.info->e.env = env;
+ if (CHECK_ENTRY)
+ if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && SRCBRKP (x)))
+ {
+ SCM tail = SCM_TAILRECP (debug) ? SCM_BOOL_T : SCM_BOOL_F;
+ SCM_SET_TAILREC (debug);
+ SCM_ENTER_FRAME_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ if (SCM_CHEAPTRAPS_P)
+ t.arg1 = scm_make_debugobj ((scm_debug_frame *) &debug);
+ else
+ {
+ scm_make_cont (&t.arg1);
+ if (setjmp (SCM_JMPBUF (t.arg1)))
+ {
+ x = SCM_THROW_VALUE (t.arg1);
+ if (SCM_IMP (x))
+ {
+ RETURN (x);
+ }
+ else
+ /* This gives the possibility for the debugger to
+ modify the source expression before evaluation. */
+ goto dispatch;
+ }
+ }
+ scm_ithrow (scm_i_enter_frame,
+ scm_cons2 (t.arg1, tail,
+ scm_cons (scm_unmemocopy (x, env), SCM_EOL)),
+ 0);
+ }
+dispatch:
+#endif
SCM_ASYNC_TICK;
-
switch (SCM_TYP7 (x))
{
case scm_tcs_symbols:
@@ -1042,10 +1549,12 @@ SCM_CEVAL (x, env)
}
else
x = t.arg1;
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
case (127 & SCM_IM_BEGIN):
-
+ cdrxnoap:
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
cdrxbegin:
x = SCM_CDR (x);
@@ -1061,13 +1570,13 @@ SCM_CEVAL (x, env)
if (SCM_NCELLP (SCM_CAR (x)))
{
x = SCM_CAR (x);
- RETURN (SCM_IMP (x) ? EVALIMP (x, env) : SCM_GLOC_VAL (x));
+ RETURN (SCM_IMP (x) ? EVALIM (x, env) : SCM_GLOC_VAL (x))
}
if (SCM_SYMBOLP (SCM_CAR (x)))
{
retval:
- RETURN (*scm_lookupcar (x, env));
+ RETURN (*scm_lookupcar (x, env))
}
x = SCM_CAR (x);
@@ -1083,6 +1592,7 @@ SCM_CEVAL (x, env)
if (scm_i_else == SCM_CAR (proc))
{
x = SCM_CDR (proc);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
}
proc = SCM_CAR (proc);
@@ -1091,12 +1601,13 @@ SCM_CEVAL (x, env)
if (CHECK_EQVISH (SCM_CAR (proc), t.arg1))
{
x = SCM_CDR (SCM_CAR (x));
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
}
proc = SCM_CDR (proc);
}
}
- RETURN (SCM_UNSPECIFIED);
+ RETURN (SCM_UNSPECIFIED)
case (127 & SCM_IM_COND):
@@ -1107,19 +1618,24 @@ SCM_CEVAL (x, env)
if (SCM_NFALSEP (t.arg1))
{
x = SCM_CDR (proc);
- if (SCM_NULLP (x))
+ if SCM_NULLP (x)
{
- RETURN (t.arg1);
+ RETURN (t.arg1)
}
if (scm_i_arrow != SCM_CAR (x))
- goto begin;
+ {
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
proc = SCM_CDR (x);
proc = EVALCAR (proc, env);
SCM_ASRTGO (SCM_NIMP (proc), badfun);
+ PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
+ ENTER_APPLY;
goto evap1;
}
}
- RETURN (SCM_UNSPECIFIED);
+ RETURN (SCM_UNSPECIFIED)
case (127 & SCM_IM_DO):
@@ -1131,7 +1647,7 @@ SCM_CEVAL (x, env)
t.arg1 = scm_cons (EVALCAR (proc, env), t.arg1);
proc = SCM_CDR (proc);
}
- env = EXTEND_SCM_ENV (SCM_CAR (x), t.arg1, env);
+ env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
x = SCM_CDR (SCM_CDR (x));
while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env)))
{
@@ -1142,13 +1658,12 @@ SCM_CEVAL (x, 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));
+ env = EXTEND_ENV (SCM_CAR (SCM_CAR (env)), t.arg1, SCM_CDR (env));
}
x = SCM_CDR (proc);
if (SCM_NULLP (x))
- {
- RETURN (SCM_UNSPECIFIED);
- }
+ RETURN (SCM_UNSPECIFIED);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin;
@@ -1160,6 +1675,7 @@ SCM_CEVAL (x, env)
{
RETURN (SCM_UNSPECIFIED);
}
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
@@ -1172,14 +1688,14 @@ SCM_CEVAL (x, env)
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);
+ env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
x = SCM_CDR (x);
- goto cdrxbegin;
+ goto cdrxnoap;
case (127 & SCM_IM_LETREC):
x = SCM_CDR (x);
- env = EXTEND_SCM_ENV (SCM_CAR (x), scm_undefineds, env);
+ env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env);
x = SCM_CDR (x);
proc = SCM_CAR (x);
t.arg1 = SCM_EOL;
@@ -1189,7 +1705,7 @@ SCM_CEVAL (x, env)
}
while (SCM_NIMP (proc = SCM_CDR (proc)));
SCM_CDR (SCM_CAR (env)) = t.arg1;
- goto cdrxbegin;
+ goto cdrxnoap;
case (127 & SCM_IM_LETSTAR):
@@ -1197,17 +1713,17 @@ SCM_CEVAL (x, env)
proc = SCM_CAR (x);
if (SCM_IMP (proc))
{
- env = EXTEND_SCM_ENV (SCM_EOL, SCM_EOL, env);
- goto cdrxbegin;
+ env = EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ goto cdrxnoap;
}
do
{
t.arg1 = SCM_CAR (proc);
proc = SCM_CDR (proc);
- env = EXTEND_SCM_ENV (t.arg1, EVALCAR (proc, env), env);
+ env = EXTEND_ENV (t.arg1, EVALCAR (proc, env), env);
}
while (SCM_NIMP (proc = SCM_CDR (proc)));
- goto cdrxbegin;
+ goto cdrxnoap;
case (127 & SCM_IM_OR):
x = SCM_CDR (x);
@@ -1221,6 +1737,7 @@ SCM_CEVAL (x, env)
}
x = t.arg1;
}
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
@@ -1233,10 +1750,9 @@ SCM_CEVAL (x, env)
case (127 & SCM_IM_SET):
- set_some_more:
x = SCM_CDR (x);
proc = SCM_CAR (x);
- switch (7 & (int)proc)
+ switch (7 & (int) proc)
{
case 0:
t.lloc = scm_lookupcar (x, env);
@@ -1252,8 +1768,6 @@ SCM_CEVAL (x, env)
}
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
@@ -1266,6 +1780,10 @@ SCM_CEVAL (x, env)
proc = SCM_CAR (x);
x = SCM_CDR (x);
x = evalcar (x, env);
+#ifdef DEBUG_EXTENSIONS
+ if (SCM_REC_PROCNAMES_P && SCM_NIMP (x) && SCM_CLOSUREP (x))
+ scm_set_procedure_property_x (x, scm_i_name, proc);
+#endif
env = SCM_CAR (env);
SCM_DEFER_INTS;
SCM_CAR (env) = scm_cons (proc, SCM_CAR (env));
@@ -1291,7 +1809,7 @@ SCM_CEVAL (x, env)
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);
+ RETURN (SCM_UNSPECIFIED)
#endif
case (SCM_ISYMNUM (SCM_IM_APPLY)):
@@ -1300,13 +1818,17 @@ SCM_CEVAL (x, env)
SCM_ASRTGO (SCM_NIMP (proc), badfun);
if (SCM_CLOSUREP (proc))
{
+ PREP_APPLY (proc, SCM_EOL);
t.arg1 = SCM_CDR (SCM_CDR (x));
t.arg1 = EVALCAR (t.arg1, env);
+#ifdef DEVAL
+ debug.info->a.args = t.arg1;
+#endif
#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));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), t.arg1, SCM_ENV (proc));
x = SCM_CODE (proc);
goto cdrxbegin;
}
@@ -1319,11 +1841,13 @@ SCM_CEVAL (x, env)
{
SCM val;
val = SCM_THROW_VALUE (t.arg1);
- RETURN (val);;
+ RETURN (val);
}
proc = SCM_CDR (x);
proc = evalcar (proc, env);
SCM_ASRTGO (SCM_NIMP (proc), badfun);
+ PREP_APPLY (proc, scm_cons (t.arg1, SCM_EOL));
+ ENTER_APPLY;
goto evap1;
default:
@@ -1333,8 +1857,12 @@ SCM_CEVAL (x, env)
default:
proc = x;
badfun:
- scm_everr (x, env, proc, "Wrong type to apply: ", "");
-
+ /* scm_everr (x, env,...) */
+ scm_error (scm_misc_error_key,
+ NULL,
+ "Wrong type to apply: %S",
+ scm_listify (proc, SCM_UNDEFINED),
+ SCM_BOOL_F);
case scm_tc7_vector:
case scm_tc7_wvect:
case scm_tc7_bvect:
@@ -1401,14 +1929,37 @@ SCM_CEVAL (x, env)
case 2:
if (scm_ilength (t.arg1) <= 0)
t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL);
+#ifdef DEVAL
+ if (!SCM_CLOSUREP (SCM_CDR (proc)))
+ {
+#if 0 /* Top-level defines doesn't very often occur in backtraces */
+ if (scm_m_define == SCM_SUBRF (SCM_CDR (proc)) && SCM_TOP_LEVEL (env))
+ /* Prevent memoizing result of define macro */
+ {
+ debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x));
+ scm_set_source_properties_x (debug.info->e.exp,
+ scm_source_properties (x));
+ }
+#endif
+ SCM_DEFER_INTS;
+ SCM_CAR (x) = SCM_CAR (t.arg1);
+ SCM_CDR (x) = SCM_CDR (t.arg1);
+ SCM_ALLOW_INTS;
+ goto dispatch;
+ }
+ /* Prevent memoizing of debug info expression. */
+ debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x));
+ scm_set_source_properties_x (debug.info->e.exp,
+ scm_source_properties (x));
+#endif
SCM_DEFER_INTS;
SCM_CAR (x) = SCM_CAR (t.arg1);
SCM_CDR (x) = SCM_CDR (t.arg1);
SCM_ALLOW_INTS;
- goto loop;
+ goto loopnoap;
case 1:
if (SCM_NIMP (x = t.arg1))
- goto loop;
+ goto loopnoap;
case 0:
RETURN (t.arg1);
}
@@ -1443,8 +1994,10 @@ SCM_CEVAL (x, env)
}
- evapply:
- if (SCM_NULLP (SCM_CDR (x)))
+evapply:
+ PREP_APPLY (proc, SCM_EOL);
+ if (SCM_NULLP (SCM_CDR (x))) {
+ ENTER_APPLY;
switch (SCM_TYP7 (proc))
{ /* no arguments given */
case scm_tc7_subr_0:
@@ -1457,13 +2010,19 @@ SCM_CEVAL (x, env)
RETURN (SCM_BOOL_T);
case scm_tc7_asubr:
RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
+#ifdef CCLO
case scm_tc7_cclo:
t.arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+ debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+#endif
goto evap1;
+#endif
case scm_tcs_closures:
x = SCM_CODE (proc);
- env = EXTEND_SCM_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
goto cdrxbegin;
case scm_tc7_contin:
case scm_tc7_subr_1:
@@ -1475,12 +2034,13 @@ SCM_CEVAL (x, env)
umwrongnumargs:
unmemocar (x, env);
wrongnumargs:
- scm_everr (x, env, proc, (char *) SCM_WNA, "");
+ /* scm_everr (x, env,...) */
+ scm_wrong_num_args (proc);
default:
/* handle macros here */
goto badfun;
}
-
+ }
/* must handle macros by here */
x = SCM_CDR (x);
@@ -1489,12 +2049,16 @@ SCM_CEVAL (x, env)
goto wrongnumargs;
#endif
t.arg1 = EVALCAR (x, env);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (t.arg1, SCM_EOL);
+#endif
x = SCM_CDR (x);
if (SCM_NULLP (x))
{
+ ENTER_APPLY;
evap1:
switch (SCM_TYP7 (proc))
- { /* have one argument in t.arg1 */
+ { /* have one argument in t.arg1 */
case scm_tc7_subr_2o:
RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
case scm_tc7_subr_1:
@@ -1541,21 +2105,27 @@ SCM_CEVAL (x, env)
RETURN (SCM_SUBRF (proc) (t.arg1, SCM_UNDEFINED));
case scm_tc7_lsubr:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (dbg_info.args));
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args))
#else
RETURN (SCM_SUBRF (proc) (scm_cons (t.arg1, SCM_EOL)));
#endif
+#ifdef CCLO
case scm_tc7_cclo:
arg2 = t.arg1;
t.arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (t.arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
+#endif
goto evap2;
+#endif
case scm_tcs_closures:
x = SCM_CODE (proc);
#ifdef DEVAL
- env = EXTEND_SCM_ENV (SCM_CAR (x), dbg_info.args, SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
#else
- env = EXTEND_SCM_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
#endif
goto cdrxbegin;
case scm_tc7_contin:
@@ -1575,154 +2145,177 @@ SCM_CEVAL (x, env)
#endif
{ /* have two or more arguments */
arg2 = EVALCAR (x, env);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
+#endif
x = SCM_CDR (x);
if (SCM_NULLP (x)) {
+ ENTER_APPLY;
#ifdef CCLO
evap2:
#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
- dbg_info.args = scm_cons2 (t.arg1, arg2, SCM_EOL);
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args))
+#else
+ RETURN (SCM_SUBRF (proc) (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:
+ 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:
#ifdef DEVAL
- RETURN (SCM_SUBRF (proc) (dbg_info.args));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
+ scm_cons (debug.info->a.args, SCM_EOL)));
#else
- RETURN (SCM_SUBRF (proc) (scm_cons2 (t.arg1, arg2, SCM_EOL)));
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), proc,
+ scm_cons2 (t.arg1, arg2,
+ scm_cons (scm_eval_args (x, env), 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:
+ /* 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));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), debug.info->a.args, SCM_ENV (proc));
#else
- env = EXTEND_SCM_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
#endif
- x = SCM_CODE (proc);
- goto cdrxbegin;
- }
+ x = SCM_CODE (proc);
+ goto cdrxbegin;
+ }
}
#ifdef DEVAL
- dbg_info.args = scm_cons2 (t.arg1, arg2, scm_deval_args (x, env));
+ debug.info->a.args = scm_cons2 (t.arg1, arg2,
+ scm_deval_args (x, env, &SCM_CDR (SCM_CDR (debug.info->a.args))));
#endif
- switch SCM_TYP7
- (proc)
- { /* have 3 or more arguments */
+ ENTER_APPLY;
+ 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));
+ 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 (debug.info->a.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 (debug.info->a.args)), SCM_EOL)))
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (t.arg1, arg2, SCM_CDR (SCM_CDR (debug.info->a.args))))
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args))
#ifdef CCLO
- case scm_tc7_cclo:
- goto cclon;
+ 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))));
+ case scm_tcs_closures:
+ SCM_SET_ARGSREADY (debug);
+ env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
+ debug.info->a.args,
+ SCM_ENV (proc));
+ x = SCM_CODE (proc);
+ goto cdrxbegin;
+#else /* DEVAL */
+ 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;
+ 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;
+ case scm_tcs_closures:
+#ifdef DEVAL
+ SCM_SET_ARGSREADY (debug);
+#endif
+ env = EXTEND_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;
- }
+ 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;
+exit:
+ if (CHECK_EXIT)
+ if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
+ {
+ SCM_EXIT_FRAME_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ SCM_CLEAR_TRACED_FRAME (debug);
+ if (SCM_CHEAPTRAPS_P)
+ t.arg1 = scm_make_debugobj ((scm_debug_frame *) &debug);
+ else
+ {
+ scm_make_cont (&t.arg1);
+ if (setjmp (SCM_JMPBUF (t.arg1)))
+ {
+ proc = SCM_THROW_VALUE (t.arg1);
+ goto ret;
+ }
+ }
+ scm_ithrow (scm_i_exit_frame, scm_cons2 (t.arg1, proc, SCM_EOL), 0);
+ }
+ret:
+ scm_last_debug_frame = debug.prev;
return proc;
#endif
}
+
+/* SECTION: This code is compiled once.
+ */
+
#ifndef DEVAL
SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation);
@@ -1760,9 +2353,21 @@ scm_procedure_documentation (proc)
}
}
-/* This code is for scm_apply. it is destructive on multiple args.
- * This will only screw you if you do (scm_apply scm_apply '( ... ))
- */
+/* This code processes the 'arg ...' parameters to apply.
+
+ (apply PROC ARG1 ... ARGS)
+
+ The ARG1 ... arguments are consed on to the front of ARGS (which
+ must be a list), and then PROC is applied to the elements of the
+ result. apply:nconc2last takes care of building the list of
+ arguments, given (ARG1 ... ARGS).
+
+ apply:nconc2last destroys its argument. On that topic, this code
+ came into my care with the following beautifully cryptic comment on
+ that topic: "This will only screw you if you do (scm_apply
+ scm_apply '( ... ))" If you know what they're referring to, send
+ me a patch to this comment. */
+
SCM_PROC(s_nconc2last, "apply:nconc2last", 1, 0, 0, scm_nconc2last);
#ifdef __STDC__
SCM
@@ -1774,21 +2379,22 @@ scm_nconc2last (lst)
#endif
{
SCM *lloc;
- if (SCM_EOL == lst)
- return lst;
- SCM_ASSERT (SCM_NIMP (lst) && SCM_CONSP (lst), lst, SCM_ARG1, s_nconc2last);
+ SCM_ASSERT (scm_ilength (lst) > 0, 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_CDR (*lloc);
+ SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, s_nconc2last);
*lloc = SCM_CAR (*lloc);
return lst;
}
#endif /* !DEVAL */
+
+/* SECTION: When DEVAL is defined this code yields scm_dapply.
+ * It is compiled twice.
+ */
+
#if 0
#ifdef __STDC__
SCM
@@ -1817,8 +2423,6 @@ scm_dapply (proc, arg1, args)
{}
#endif
-
-
#ifdef __STDC__
SCM
SCM_APPLY (SCM proc, SCM arg1, SCM args)
@@ -1832,14 +2436,14 @@ SCM_APPLY (proc, arg1, args)
{
#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)
+ scm_debug_frame debug;
+ debug.prev = scm_last_debug_frame;
+ debug.status = SCM_APPLYFRAME;
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = SCM_EOL;
+ scm_last_debug_frame = &debug;
+#else
+ if (SCM_DEBUGGINGP)
return scm_dapply (proc, arg1, args);
#endif
#endif
@@ -1860,11 +2464,28 @@ SCM_APPLY (proc, arg1, args)
/* 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);
+ debug.vect[0].a.args = scm_cons (arg1, args);
+ if (SCM_ENTER_FRAME_P)
+ {
+ SCM tmp;
+ SCM_ENTER_FRAME_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ if (SCM_CHEAPTRAPS_P)
+ tmp = scm_make_debugobj ((scm_debug_frame *) &debug);
+ else
+ {
+ scm_make_cont (&tmp);
+ if (setjmp (SCM_JMPBUF (tmp)))
+ goto entap;
+ }
+ scm_ithrow (scm_i_enter_frame, scm_cons (tmp, SCM_EOL), 0);
+ }
+entap:
+ ENTER_APPLY;
+#endif
+#ifdef CCLO
+tail:
#endif
switch (SCM_TYP7 (proc))
{
@@ -1887,13 +2508,15 @@ SCM_APPLY (proc, arg1, args)
#ifdef SCM_FLOATS
if (SCM_SUBRF (proc))
{
- if SCM_INUMP
- (arg1)
- RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0))
+ 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))
+ if (SCM_REALP (arg1))
+ {
+ RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0));
+ }
#ifdef SCM_BIGDIG
if SCM_BIGP
(arg1)
@@ -1918,7 +2541,7 @@ SCM_APPLY (proc, arg1, args)
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))
+ RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args))
#else
RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)))
#endif
@@ -1949,7 +2572,7 @@ SCM_APPLY (proc, arg1, args)
RETURN (SCM_BOOL_T);
case scm_tcs_closures:
#ifdef DEVAL
- arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : dbg_info.args);
+ arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
#else
arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
@@ -1957,7 +2580,7 @@ SCM_APPLY (proc, arg1, args)
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));
+ args = EXTEND_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);
@@ -1968,41 +2591,56 @@ SCM_APPLY (proc, arg1, args)
#ifdef CCLO
case scm_tc7_cclo:
#ifdef DEVAL
- args = (SCM_UNBNDP(arg1) ? SCM_EOL : dbg_info.args);
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = scm_cons (arg1, args);
#else
args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
-#endif
arg1 = proc;
proc = SCM_CCLO_SUBR (proc);
+#endif
goto tail;
#endif
wrongnumargs:
- scm_wta (proc, (char *) SCM_WNA, "apply");
+ scm_wrong_num_args (proc);
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;
+exit:
+ if (CHECK_EXIT)
+ if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
+ {
+ SCM_EXIT_FRAME_P = 0;
+ SCM_RESET_DEBUG_MODE;
+ SCM_CLEAR_TRACED_FRAME (debug);
+ if (SCM_CHEAPTRAPS_P)
+ arg1 = scm_make_debugobj ((scm_debug_frame *) &debug);
+ else
+ {
+ scm_make_cont (&arg1);
+ if (setjmp (SCM_JMPBUF (arg1)))
+ {
+ proc = SCM_THROW_VALUE (arg1);
+ goto ret;
+ }
+ }
+ scm_ithrow (scm_i_exit_frame, scm_cons2 (arg1, proc, SCM_EOL), 0);
+ }
+ret:
+ scm_last_debug_frame = debug.prev;
return proc;
#endif
}
+
+/* SECTION: The rest of this file is only read once.
+ */
+
#ifndef DEVAL
SCM_PROC(s_map, "map", 2, 0, 1, scm_map);
@@ -2144,17 +2782,20 @@ scm_makprom (code)
#ifdef __STDC__
static int
-prinprom (SCM exp, SCM port, int writing)
+prinprom (SCM exp, SCM port, scm_print_state *pstate)
#else
static int
-prinprom (exp, port, writing)
+prinprom (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
+ int writingp = SCM_WRITINGP (pstate);
scm_gen_puts (scm_regular_string, "#<promise ", port);
- scm_iprin1 (SCM_CDR (exp), port, writing);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (SCM_CDR (exp), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
scm_gen_putc ('>', port);
return !0;
}
@@ -2216,15 +2857,16 @@ scm_makmmacro (code)
#ifdef __STDC__
static int
-prinmacro (SCM exp, SCM port, int writing)
+prinmacro (SCM exp, SCM port, scm_print_state *pstate)
#else
static int
-prinmacro (exp, port, writing)
+prinmacro (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
+ int writingp = SCM_WRITINGP (pstate);
if (SCM_CAR (exp) & (3L << 16))
scm_gen_puts (scm_regular_string, "#<macro", port);
else
@@ -2232,7 +2874,9 @@ prinmacro (exp, port, writing)
if (SCM_CAR (exp) & (2L << 16))
scm_gen_putc ('!', port);
scm_gen_putc (' ', port);
- scm_iprin1 (SCM_CDR (exp), port, writing);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (SCM_CDR (exp), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
scm_gen_putc ('>', port);
return !0;
}
@@ -2323,7 +2967,7 @@ scm_eval_3 (obj, copyp, env)
obj = scm_apply (SCM_CDR (scm_system_transformer), obj, scm_listofnull);
else if (copyp)
obj = scm_copy_tree (obj);
- return EVAL (obj, env);
+ return XEVAL (obj, env);
}
#ifdef __STDC__
@@ -2450,11 +3094,13 @@ scm_make_synt (name, macroizer, fcn)
return SCM_CAR (symcell);
}
+
+/* At this point, scm_deval and scm_dapply are generated.
+ */
+
#ifdef DEBUG_EXTENSIONS
-# ifndef DEVAL
-# define DEVAL
-# include "eval.c"
-# endif
+# define DEVAL
+# include "eval.c"
#endif
@@ -2466,10 +3112,6 @@ 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 (&macrosmob);
scm_i_apply = scm_make_subr ("apply", scm_tc7_lsubr_2, scm_apply);
@@ -2482,32 +3124,43 @@ scm_init_eval ()
/* 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_undefine, scm_makacro, scm_m_undefine);
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_and = scm_make_synt ("and", scm_makmmacro, scm_m_and);
+ scm_i_begin = scm_make_synt ("begin", scm_makmmacro, scm_m_begin);
+ scm_i_case = scm_make_synt ("case", scm_makmmacro, scm_m_case);
+ scm_i_cond = scm_make_synt ("cond", scm_makmmacro, scm_m_cond);
+ scm_i_define = scm_make_synt ("define", scm_makmmacro, scm_m_define);
+ scm_i_do = scm_make_synt ("do", scm_makmmacro, scm_m_do);
+ scm_i_if = 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_letrec = scm_make_synt ("letrec", scm_makmmacro, scm_m_letrec);
+ scm_i_letstar = scm_make_synt ("let*", scm_makmmacro, scm_m_letstar);
+ scm_i_or = 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_i_set = scm_make_synt ("set!", scm_makmmacro, scm_m_set);
+ scm_i_atapply = scm_make_synt ("@apply", scm_makmmacro, scm_m_apply);
+ scm_i_atcall_cc = 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);
+
+#ifdef DEBUG_EXTENSIONS
+ scm_i_enter_frame = SCM_CAR (scm_sysintern ("enter-frame", SCM_UNDEFINED));
+ scm_i_apply_frame = SCM_CAR (scm_sysintern ("apply-frame", SCM_UNDEFINED));
+ scm_i_exit_frame = SCM_CAR (scm_sysintern ("exit-frame", SCM_UNDEFINED));
+ scm_i_trace = SCM_CAR (scm_sysintern ("trace", SCM_UNDEFINED));
+#endif
+
#include "eval.x"
}
-#endif /* !DEVAL */
+#endif /* !DEVAL */
diff --git a/libguile/eval.h b/libguile/eval.h
index fb8c0c9ec..fb40b7ece 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -66,22 +66,24 @@
-/* Evaluator */
+/* {Evaluator}
+ *
+ * For an explanation of symbols containing "EVAL", see beginning of eval.c.
+ */
#ifdef DEBUG_EXTENSIONS
-#define EVAL(x, env) (SCM_IMP(x) \
+#define XEVAL(x, env) (SCM_IMP(x) \
? (x) \
: (*scm_ceval_ptr) ((x), (env)))
#else
-#define EVAL(x, env) (SCM_IMP(x)?(x):scm_ceval((x), (env)))
+#define XEVAL(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
+#define SCM_EXTEND_ENV scm_acons
extern SCM scm_i_dot;
@@ -94,7 +96,6 @@ 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;
@@ -111,7 +112,10 @@ extern SCM scm_i_name;
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_unmemocopy (SCM form, SCM env);
extern SCM scm_eval_car (SCM pair, SCM env);
+extern SCM scm_eval_args (SCM i, SCM env);
+extern SCM scm_deval_args (SCM l, SCM env, SCM *lloc);
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);
@@ -132,6 +136,7 @@ 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 SCM scm_m_undefine (SCM x, 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);
@@ -164,7 +169,10 @@ extern void scm_init_eval (void);
extern SCM * scm_ilookup ();
extern SCM * scm_lookupcar ();
extern SCM scm_unmemocar ();
+extern SCM scm_unmemocopy ();
extern SCM scm_eval_car ();
+extern SCM scm_eval_args ();
+extern SCM scm_deval_args ();
extern SCM scm_m_quote ();
extern SCM scm_m_begin ();
extern SCM scm_m_if ();
@@ -185,6 +193,7 @@ extern SCM scm_m_letrec ();
extern SCM scm_m_let ();
extern SCM scm_m_apply ();
extern SCM scm_m_cont ();
+extern SCM scm_m_undefine ();
extern int scm_badargsp ();
extern SCM scm_ceval ();
extern SCM scm_deval ();
diff --git a/libguile/extchrs.c b/libguile/extchrs.c
index 44d9a14a1..1b7fb2bbb 100644
--- a/libguile/extchrs.c
+++ b/libguile/extchrs.c
@@ -44,7 +44,7 @@
-#ifdef FAKE_EXT_SCM_CHARS
+#ifdef SCM_FAKE_EXT_CHARS
#ifdef __STDC__
int
@@ -142,5 +142,5 @@ xmbtowc (result, str, size)
return 4;
}
-#endif /* FAKE_EXT_SCM_CHARS */
+#endif /* SCM_FAKE_EXT_CHARS */
diff --git a/libguile/extchrs.h b/libguile/extchrs.h
index 8d17c4681..6a4a3ceb8 100644
--- a/libguile/extchrs.h
+++ b/libguile/extchrs.h
@@ -46,9 +46,9 @@
#include <stdlib.h>
-#define FAKE_EXT_SCM_CHARS 1
+#define SCM_FAKE_EXT_CHARS 1
-#if !defined(FAKE_EXT_SCM_CHARS)
+#if !defined(SCM_FAKE_EXT_CHARS)
#define xmblen mblen
#define xwctomb wctomb
diff --git a/libguile/feature.c b/libguile/feature.c
index b4622b7e9..fceaea902 100644
--- a/libguile/feature.c
+++ b/libguile/feature.c
@@ -43,71 +43,38 @@
#include <stdio.h>
#include "_scm.h"
+#include "feature.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
-SCM *scm_loc_features;
+static 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_loc_features = scm_cons(SCM_CAR(scm_intern(str, strlen(str))),
+ *scm_loc_features);
}
SCM_PROC(s_program_arguments, "program-arguments", 0, 0, 0, scm_program_arguments);
-#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
@@ -128,8 +95,10 @@ scm_init_feature()
#ifndef CHEAP_CONTINUATIONS
scm_add_feature ("full-continuation");
#endif
-
-
- scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_SCM_CODE_LIMIT));
+#ifdef USE_THREADS
+ scm_add_feature ("threads");
+#endif
+
+ scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT));
#include "feature.x"
}
diff --git a/libguile/feature.h b/libguile/feature.h
index c1f7b1cb8..5371d3718 100644
--- a/libguile/feature.h
+++ b/libguile/feature.h
@@ -44,26 +44,10 @@
*/
-#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 */
+#include "libguile/__scm.h"
+extern void scm_add_feature SCM_P((char* str));
+extern SCM scm_program_arguments SCM_P((void));
+extern void scm_init_feature SCM_P((void));
#endif /* FEATUREH */
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 5ca9b309c..b0ef9bb81 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -40,7 +40,11 @@
*/
#include "_scm.h"
+#include "genio.h"
+#include "smob.h"
+#include "feature.h"
+#include "filesys.h"
#ifdef TIME_WITH_SYS_TIME
# include <sys/time.h>
@@ -57,10 +61,19 @@
#include <unistd.h>
#endif
+#ifdef HAVE_LIBC_H
+#include <libc.h>
+#endif
+
#ifdef HAVE_SYS_SELECT_H
#include <sys/select.h>
#endif
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
@@ -142,7 +155,7 @@ SCM_CONST_LONG (scm_O_SYNC, "O_SYNC", O_SYNC);
/* {Permissions}
*/
-SCM_PROC (s_sys_chown, "%chown", 3, 0, 0, scm_sys_chown);
+SCM_PROC (s_sys_chown, "chown", 3, 0, 0, scm_sys_chown);
#ifdef __STDC__
SCM
scm_sys_chown (SCM path, SCM owner, SCM group)
@@ -155,17 +168,21 @@ scm_sys_chown (path, owner, 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_SYSCALL (val = chown (SCM_ROCHARS (path),
+ SCM_INUM (owner), SCM_INUM (group)));
+ if (val != 0)
+ scm_syserror (s_sys_chown);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_chmod, "%chmod", 2, 0, 0, scm_sys_chmod);
+SCM_PROC (s_sys_chmod, "chmod", 2, 0, 0, scm_sys_chmod);
#ifdef __STDC__
SCM
scm_sys_chmod (SCM port_or_path, SCM mode)
@@ -188,7 +205,9 @@ scm_sys_chmod (port_or_path, mode)
if (rv != -1)
SCM_SYSCALL (rv = fchmod (rv, SCM_INUM (mode)));
}
- return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (rv != 0)
+ scm_syserror (s_sys_chmod);
+ return SCM_UNSPECIFIED;
}
SCM_PROC (s_umask, "umask", 0, 1, 0, scm_umask);
@@ -222,13 +241,13 @@ long scm_tc16_fd;
#ifdef __STDC__
static int
-scm_fd_print (SCM sexp, SCM port, int writing)
+scm_fd_print (SCM sexp, SCM port, scm_print_state *pstate)
#else
static int
-scm_fd_print (sexp, port, writing)
+scm_fd_print (sexp, port, pstate)
SCM sexp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
scm_gen_puts (scm_regular_string, "#<fd ", port);
@@ -279,7 +298,7 @@ scm_intern_fd (fd, flags)
-SCM_PROC (s_sys_open, "%open", 3, 0, 0, scm_sys_open);
+SCM_PROC (s_sys_open, "open", 3, 0, 0, scm_sys_open);
#ifdef __STDC__
SCM
scm_sys_open (SCM path, SCM flags, SCM mode)
@@ -304,16 +323,15 @@ scm_sys_open (path, flags, mode)
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_syserror (s_sys_open);
+ sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc);
SCM_ALLOW_INTS;
return scm_return_first (sfd, path);
}
-SCM_PROC (s_sys_create, "%create", 2, 0, 0, scm_sys_create);
+SCM_PROC (s_sys_create, "create", 2, 0, 0, scm_sys_create);
#ifdef __STDC__
SCM
scm_sys_create (SCM path, SCM mode)
@@ -336,16 +354,15 @@ scm_sys_create (path, mode)
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_syserror (s_sys_create);
+ sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc);
SCM_ALLOW_INTS;
return scm_return_first (sfd, path);
}
-SCM_PROC (s_sys_close, "%close", 1, 0, 0, scm_sys_close);
+SCM_PROC (s_sys_close, "close", 1, 0, 0, scm_sys_close);
#ifdef __STDC__
SCM
scm_sys_close (SCM sfd)
@@ -364,11 +381,13 @@ scm_sys_close (sfd)
got = close (fd);
SCM_SETCAR (sfd, scm_tc16_fd);
SCM_ALLOW_INTS;
- return (got == -1 ? SCM_MAKINUM (errno) : SCM_BOOL_T);
+ if (got == -1)
+ scm_syserror (s_sys_close);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_write_fd, "%write-fd", 2, 0, 0, scm_sys_write_fd);
+SCM_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)
@@ -388,15 +407,14 @@ scm_sys_write_fd (sfd, buf)
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_syserror (s_sys_write_fd);
+ answer = scm_long2num (written);
SCM_ALLOW_INTS;
return scm_return_first (answer, buf);
}
-SCM_PROC (s_sys_read_fd, "%read-fd", 2, 2, 0, scm_sys_read_fd);
+SCM_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)
@@ -441,14 +459,13 @@ scm_sys_read_fd (sfd, buf, offset, 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_syserror (s_sys_read_fd);
+ answer = scm_long2num (got);
SCM_ALLOW_INTS;
return scm_return_first (answer, buf);
}
-SCM_PROC (s_sys_lseek, "%lseek", 2, 1, 0, scm_sys_lseek);
+SCM_PROC (s_sys_lseek, "lseek", 2, 1, 0, scm_sys_lseek);
#ifdef __STDC__
SCM
scm_sys_lseek (SCM sfd, SCM offset, SCM whence)
@@ -481,15 +498,14 @@ scm_sys_lseek (sfd, offset, whence)
SCM_DEFER_INTS;
SCM_SYSCALL (got = lseek (fd, off, wh));
if (got == -1)
- answer = SCM_MAKINUM (errno);
- else
- answer = scm_long2num (got);
+ scm_syserror (s_sys_lseek);
+ answer = scm_long2num (got);
SCM_ALLOW_INTS;
return answer;
}
-SCM_PROC (s_sys_dup, "%dup", 1, 1, 0, scm_sys_dup);
+SCM_PROC (s_sys_dup, "dup", 1, 1, 0, scm_sys_dup);
#ifdef __STDC__
SCM
scm_sys_dup (SCM oldfd, SCM newfd)
@@ -513,9 +529,9 @@ scm_sys_dup (oldfd, newfd)
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));
+ if (nfd == -1)
+ scm_syserror (s_sys_dup);
+ answer = SCM_MAKINUM (nfd);
SCM_ALLOW_INTS;
return answer;
}
@@ -564,7 +580,7 @@ scm_stat2scm (stat_temp)
return ans;
}
-SCM_PROC (s_sys_stat, "%stat", 1, 0, 0, scm_sys_stat);
+SCM_PROC (s_sys_stat, "stat", 1, 0, 0, scm_sys_stat);
#ifdef __STDC__
SCM
scm_sys_stat (SCM fd_or_path)
@@ -574,12 +590,11 @@ scm_sys_stat (fd_or_path)
SCM fd_or_path;
#endif
{
- int rv;
+ int rv = 1;
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));
}
@@ -600,7 +615,12 @@ scm_sys_stat (fd_or_path)
}
}
- return rv ? SCM_MAKINUM (errno) : scm_stat2scm (&stat_temp);
+ if (rv != 0)
+ scm_syserror_msg (s_sys_stat, "%s: %S",
+ scm_listify (scm_makfrom0str (strerror (errno)),
+ fd_or_path,
+ SCM_UNDEFINED));
+ return scm_stat2scm (&stat_temp);
}
@@ -608,7 +628,7 @@ scm_sys_stat (fd_or_path)
/* {Modifying Directories}
*/
-SCM_PROC (s_sys_link, "%link", 2, 0, 0, scm_sys_link);
+SCM_PROC (s_sys_link, "link", 2, 0, 0, scm_sys_link);
#ifdef __STDC__
SCM
scm_sys_link (SCM oldpath, SCM newpath)
@@ -620,6 +640,7 @@ scm_sys_link (oldpath, 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);
@@ -627,12 +648,14 @@ scm_sys_link (oldpath, newpath)
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;
+ if (val != 0)
+ scm_syserror (s_sys_link);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_rename, "%rename-file", 2, 0, 0, scm_sys_rename);
+SCM_PROC (s_sys_rename, "rename-file", 2, 0, 0, scm_sys_rename);
#ifdef __STDC__
SCM
scm_sys_rename (SCM oldname, SCM newname)
@@ -648,25 +671,47 @@ scm_sys_rename (oldname, newname)
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;
+ if (rv != 0)
+ scm_syserror (s_sys_rename);
+ return SCM_UNSPECIFIED;
#else
SCM_DEFER_INTS;
SCM_SYSCALL (rv = link (SCM_CHARS (oldname), SCM_CHARS (newname)));
- if (!rv)
+ if (rv == 0)
{
SCM_SYSCALL (rv = unlink (SCM_CHARS (oldname)));;
- if (rv)
+ if (rv != 0)
/* unlink failed. remove new name */
SCM_SYSCALL (unlink (SCM_CHARS (newname)));
}
SCM_ALLOW_INTS;
- return rv ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (rv != 0)
+ scm_syserror (s_sys_rename);
+ return SCM_UNSPECIFIED;
#endif
}
+SCM_PROC(s_sys_delete_file, "delete-file", 1, 0, 0, scm_sys_delete_file);
+#ifdef __STDC__
+SCM
+scm_sys_delete_file (SCM str)
+#else
+SCM
+scm_sys_delete_file (str)
+ SCM str;
+#endif
+{
+ int ans;
+ SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_delete_file);
+ SCM_SYSCALL (ans = unlink (SCM_CHARS (str)));
+ if (ans != 0)
+ scm_syserror (s_sys_delete_file);
+ return SCM_UNSPECIFIED;
+}
+
-SCM_PROC (s_sys_mkdir, "%mkdir", 1, 1, 0, scm_sys_mkdir);
+SCM_PROC (s_sys_mkdir, "mkdir", 1, 1, 0, scm_sys_mkdir);
#ifdef __STDC__
SCM
scm_sys_mkdir (SCM path, SCM mode)
@@ -692,14 +737,18 @@ scm_sys_mkdir (path, mode)
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;
+ if (rv != 0)
+ scm_syserror (s_sys_mkdir);
+ return SCM_UNSPECIFIED;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_sys_mkdir);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_rmdir, "%rmdir", 1, 0, 0, scm_sys_rmdir);
+SCM_PROC (s_sys_rmdir, "rmdir", 1, 0, 0, scm_sys_rmdir);
#ifdef __STDC__
SCM
scm_sys_rmdir (SCM path)
@@ -711,11 +760,16 @@ scm_sys_rmdir (path)
{
#ifdef HAVE_RMDIR
int val;
+
SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_sys_rmdir);
SCM_SYSCALL (val = rmdir (SCM_CHARS (path)));
- return val ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (val != 0)
+ scm_syserror (s_sys_rmdir);
+ return SCM_UNSPECIFIED;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_sys_rmdir);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
@@ -725,7 +779,7 @@ scm_sys_rmdir (path)
long scm_tc16_dir;
-SCM_PROC (s_sys_opendir, "%opendir", 1, 0, 0, scm_sys_opendir);
+SCM_PROC (s_sys_opendir, "opendir", 1, 0, 0, scm_sys_opendir);
#ifdef __STDC__
SCM
scm_sys_opendir (SCM dirname)
@@ -741,11 +795,8 @@ scm_sys_opendir (dirname)
SCM_NEWCELL (dir);
SCM_DEFER_INTS;
SCM_SYSCALL (ds = opendir (SCM_CHARS (dirname)));
- if (!ds)
- {
- SCM_ALLOW_INTS;
- return SCM_MAKINUM (errno);
- }
+ if (ds == NULL)
+ scm_syserror (s_sys_opendir);
SCM_CAR (dir) = scm_tc16_dir | SCM_OPN;
SCM_SETCDR (dir, ds);
SCM_ALLOW_INTS;
@@ -753,7 +804,7 @@ scm_sys_opendir (dirname)
}
-SCM_PROC (s_sys_readdir, "%readdir", 1, 0, 0, scm_sys_readdir);
+SCM_PROC (s_sys_readdir, "readdir", 1, 0, 0, scm_sys_readdir);
#ifdef __STDC__
SCM
scm_sys_readdir (SCM port)
@@ -769,9 +820,10 @@ scm_sys_readdir (port)
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));
+ if (errno != 0)
+ scm_syserror (s_sys_readdir);
+ return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
+ : SCM_EOF_VAL);
}
@@ -793,7 +845,7 @@ scm_rewinddir (port)
-SCM_PROC (s_sys_closedir, "%closedir", 1, 0, 0, scm_sys_closedir);
+SCM_PROC (s_sys_closedir, "closedir", 1, 0, 0, scm_sys_closedir);
#ifdef __STDC__
SCM
scm_sys_closedir (SCM port)
@@ -804,35 +856,33 @@ scm_sys_closedir (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);
+ return SCM_UNSPECIFIED;
}
SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port)));
- if (sts)
- {
- SCM_ALLOW_INTS;
- return SCM_MAKINUM (errno);
- }
+ if (sts != 0)
+ scm_syserror (s_sys_closedir);
SCM_CAR (port) = scm_tc16_dir;
SCM_ALLOW_INTS;
- return SCM_BOOL_T;
+ return SCM_UNSPECIFIED;
}
#ifdef __STDC__
static int
-scm_dir_print (SCM sexp, SCM port, int writing)
+scm_dir_print (SCM sexp, SCM port, scm_print_state *pstate)
#else
static int
-scm_dir_print (sexp, port, writing)
+scm_dir_print (sexp, port, pstate)
SCM sexp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
scm_prinport (sexp, port, "directory");
@@ -860,7 +910,7 @@ static scm_smobfuns dir_smob = {scm_mark0, scm_dir_free, scm_dir_print, 0};
*/
-SCM_PROC (s_sys_chdir, "%chdir", 1, 0, 0, scm_sys_chdir);
+SCM_PROC (s_sys_chdir, "chdir", 1, 0, 0, scm_sys_chdir);
#ifdef __STDC__
SCM
scm_sys_chdir (SCM str)
@@ -871,14 +921,17 @@ scm_sys_chdir (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;
+ if (ans != 0)
+ scm_syserror (s_sys_chdir);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_getcwd, "%getcwd", 0, 0, 0, scm_sys_getcwd);
+SCM_PROC (s_sys_getcwd, "getcwd", 0, 0, 0, scm_sys_getcwd);
#ifdef __STDC__
SCM
scm_sys_getcwd (void)
@@ -902,15 +955,16 @@ scm_sys_getcwd ()
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);
+ if (rv == 0)
+ scm_syserror (s_sys_getcwd);
+ result = scm_makfromstr (wd, strlen (wd), 0);
scm_must_free (wd);
SCM_ALLOW_INTS;
return result;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_sys_getcwd);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
@@ -977,7 +1031,7 @@ retrieve_select_type (set, list)
}
-SCM_PROC (s_sys_select, "%select", 3, 2, 0, scm_sys_select);
+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)
@@ -1029,16 +1083,17 @@ scm_sys_select (reads, writes, excepts, secs, msecs)
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);
+ scm_syserror (s_sys_select);
+ SCM_ALLOW_INTS;
+ return scm_listify (retrieve_select_type (&read_set, reads),
+ retrieve_select_type (&write_set, writes),
+ retrieve_select_type (&except_set, excepts),
+ SCM_UNDEFINED);
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_sys_select);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
@@ -1046,7 +1101,7 @@ scm_sys_select (reads, writes, excepts, secs, msecs)
/* {Symbolic Links}
*/
-SCM_PROC (s_sys_symlink, "%symlink", 2, 0, 0, scm_sys_symlink);
+SCM_PROC (s_sys_symlink, "symlink", 2, 0, 0, scm_sys_symlink);
#ifdef __STDC__
SCM
scm_sys_symlink(SCM oldpath, SCM newpath)
@@ -1059,17 +1114,22 @@ scm_sys_symlink(oldpath, newpath)
{
#ifdef HAVE_SYMLINK
int val;
+
SCM_ASSERT(SCM_NIMP(oldpath) && SCM_STRINGP(oldpath), oldpath, SCM_ARG1, s_sys_symlink);
SCM_ASSERT(SCM_NIMP(newpath) && SCM_STRINGP(newpath), newpath, SCM_ARG2, s_sys_symlink);
- SCM_SYSCALL(val = symlink(SCM_CHARS(oldpath), SCM_CHARS(newpath)));
- return val ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ SCM_SYSCALL (val = symlink(SCM_CHARS(oldpath), SCM_CHARS(newpath)));
+ if (val != 0)
+ scm_syserror (s_sys_symlink);
+ return SCM_UNSPECIFIED;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_sys_symlink);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_readlink, "%readlink", 1, 0, 0, scm_sys_readlink);
+SCM_PROC (s_sys_readlink, "readlink", 1, 0, 0, scm_sys_readlink);
#ifdef __STDC__
SCM
scm_sys_readlink(SCM path)
@@ -1093,20 +1153,21 @@ scm_sys_readlink(path)
size *= 2;
buf = scm_must_malloc (size, s_sys_readlink);
}
- if (rv != -1)
- result = scm_makfromstr (buf, rv, 0);
- else
- result = SCM_MAKINUM (errno);
+ if (rv == -1)
+ scm_syserror (s_sys_readlink);
+ result = scm_makfromstr (buf, rv, 0);
scm_must_free (buf);
SCM_ALLOW_INTS;
return result;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_sys_readlink);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_lstat, "%lstat", 1, 0, 0, scm_sys_lstat);
+SCM_PROC (s_sys_lstat, "lstat", 1, 0, 0, scm_sys_lstat);
#ifdef __STDC__
SCM
scm_sys_lstat(SCM str)
@@ -1116,19 +1177,27 @@ scm_sys_lstat(str)
SCM str;
#endif
{
-#ifdef HAVE_LSTATE
- int i;
+#ifdef HAVE_LSTAT
+ int rv;
struct stat stat_temp;
+
SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, (char *)SCM_ARG1, s_sys_lstat);
- SCM_SYSCALL(i = lstat(SCM_CHARS(str), &stat_temp));
- return i ? SCM_MAKINUM (errno) : scm_stat2scm(&stat_temp);
+ SCM_SYSCALL(rv = lstat(SCM_CHARS(str), &stat_temp));
+ if (rv != 0)
+ scm_syserror_msg (s_sys_lstat, "%s: %S",
+ scm_listify (scm_makfrom0str (strerror (errno)),
+ str,
+ SCM_UNDEFINED));
+ return scm_stat2scm(&stat_temp);
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_sys_lstat);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_copy_file, "%copy-file", 2, 0, 0, scm_sys_copy_file);
+SCM_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)
@@ -1151,39 +1220,30 @@ scm_sys_copy_file (oldfile, newfile)
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_syserror (s_sys_copy_file);
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. */
+ scm_syserror (s_sys_copy_file);
+
+ /* use POSIX flags instead of 07777?. */
newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC,
oldstat.st_mode & 07777);
if (newfd == -1)
- {
- close (oldfd);
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
+ scm_syserror (s_sys_copy_file);
+
while ((n = read (oldfd, buf, sizeof buf)) > 0)
if (write (newfd, buf, n) != n)
{
close (oldfd);
close (newfd);
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
+ scm_syserror (s_sys_copy_file);
}
close (oldfd);
if (close (newfd) == -1)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
+ scm_syserror (s_sys_copy_file);
SCM_ALLOW_INTS;
- return SCM_BOOL_T;
+ return SCM_UNSPECIFIED;
}
@@ -1195,6 +1255,7 @@ void
scm_init_filesys ()
#endif
{
+ scm_add_feature ("i/o-extensions");
/* File type/permission bits. */
#ifdef S_IRUSR
scm_sysintern ("S_IRUSR", SCM_MAKINUM (S_IRUSR));
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 9949d383b..9dce3ae81 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -45,7 +45,7 @@
#include <stdio.h>
-#include "_scm.h"
+#include "libguile/__scm.h"
@@ -85,6 +85,7 @@ 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_delete_file (SCM str);
extern SCM scm_sys_mkdir (SCM path, SCM mode);
extern SCM scm_sys_rmdir (SCM path);
extern SCM scm_sys_opendir (SCM dirname);
@@ -115,6 +116,7 @@ extern SCM scm_sys_dup ();
extern SCM scm_sys_stat ();
extern SCM scm_sys_link ();
extern SCM scm_sys_rename ();
+extern SCM scm_sys_delete_file ();
extern SCM scm_sys_mkdir ();
extern SCM scm_sys_rmdir ();
extern SCM scm_sys_opendir ();
diff --git a/libguile/fports.c b/libguile/fports.c
index 234c21d26..64842d653 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -42,22 +42,23 @@
#include <stdio.h>
#include "_scm.h"
+#include "markers.h"
+
+#include "fports.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#else
-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
@@ -139,64 +140,54 @@ scm_mode_bits (modes)
*
* Return the new port.
*/
-
+SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
#ifdef __STDC__
SCM
-scm_mkfile (char * name, char * modes)
+scm_open_file (SCM filename, SCM modes)
#else
SCM
-scm_mkfile (name, modes)
- char * name;
- char * modes;
+scm_open_file (filename, modes)
+ SCM filename;
+ SCM modes;
#endif
{
- register SCM port;
+ SCM port;
FILE *f;
+ char *file;
+ char *mode;
+
+ SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
+ SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
+ if (SCM_SUBSTRP (filename))
+ filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
+ if (SCM_SUBSTRP (modes))
+ modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
+
+ file = SCM_ROCHARS (filename);
+ mode = SCM_ROCHARS (modes);
+
SCM_NEWCELL (port);
SCM_DEFER_INTS;
- SCM_SYSCALL (f = fopen (name, modes));
+ SCM_SYSCALL (f = fopen (file, mode));
if (!f)
{
- SCM_ALLOW_INTS;
- port = SCM_BOOL_F;
+ scm_syserror_msg (s_open_file, "%s: %S",
+ scm_listify (scm_makfrom0str (strerror (errno)),
+ filename,
+ SCM_UNDEFINED));
}
else
{
struct scm_port_table * pt;
+
pt = scm_add_to_port_table (port);
SCM_SETPTAB_ENTRY (port, pt);
- if (SCM_BUF0 & (SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (modes)))
+ if (SCM_BUF0 & (SCM_CAR (port) = scm_tc16_fport | scm_mode_bits (mode)))
scm_setbuf0 (port);
SCM_SETSTREAM (port, (SCM)f);
- SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name);
- SCM_ALLOW_INTS;
+ SCM_PTAB_ENTRY (port)->file_name = filename;
}
- 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);
+ SCM_ALLOW_INTS;
return port;
}
@@ -257,7 +248,7 @@ prinfport (exp, port, writing)
else
c = "file";
}
-
+
scm_prinport (exp, port, c);
return !0;
}
diff --git a/libguile/fports.h b/libguile/fports.h
index a0ca6fe3b..15ce0b588 100644
--- a/libguile/fports.h
+++ b/libguile/fports.h
@@ -44,7 +44,9 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+
+#include "libguile/ports.h"
@@ -55,7 +57,6 @@ 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);
diff --git a/libguile/gc.c b/libguile/gc.c
index 26e718158..3ab6104c2 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -41,13 +41,23 @@
#include <stdio.h>
#include "_scm.h"
+#include "stime.h"
+#include "stackchk.h"
+#include "struct.h"
+#include "genio.h"
+#include "weaks.h"
+#include "smob.h"
+#include "unif.h"
+#include "async.h"
+
+#include "gc.h"
#ifdef HAVE_MALLOC_H
-#include "malloc.h"
+#include <malloc.h>
#endif
#ifdef HAVE_UNISTD_H
-#include "unistd.h"
+#include <unistd.h>
#endif
@@ -177,9 +187,9 @@ struct scm_heap_seg_data
-
-static void alloc_some_heap ();
-static void scm_mark_weak_vector_spines ();
+static void scm_mark_weak_vector_spines SCM_P ((void));
+static scm_sizet init_heap_seg SCM_P ((SCM_CELLPTR, scm_sizet, int, SCM *));
+static void alloc_some_heap SCM_P ((int, SCM *));
@@ -188,13 +198,8 @@ static void scm_mark_weak_vector_spines ();
*/
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;
@@ -237,14 +242,9 @@ scm_gc_stats ()
}
-#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;
@@ -252,13 +252,8 @@ scm_gc_start (what)
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;
@@ -276,13 +271,8 @@ scm_object_addr (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");
@@ -295,15 +285,10 @@ scm_gc ()
/* {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");
@@ -315,13 +300,8 @@ scm_gc_for_alloc (ncells, freelistp)
}
-#ifdef __STDC__
-SCM
-scm_gc_for_newcell (void)
-#else
SCM
scm_gc_for_newcell ()
-#endif
{
SCM fl;
scm_gc_for_alloc (1, &scm_freelist);
@@ -330,17 +310,17 @@ scm_gc_for_newcell ()
return fl;
}
-#ifdef __STDC__
-void
-scm_igc (char *what)
-#else
void
scm_igc (what)
char *what;
-#endif
{
int j;
+#ifdef USE_THREADS
+ /* During the critical section, only the current thread may run. */
+ SCM_THREAD_CRITICAL_SECTION_START;
+#endif
+
scm_gc_start (what);
if (!scm_stack_base || scm_block_gc)
{
@@ -388,6 +368,8 @@ scm_igc (what)
}
}
+#ifndef USE_THREADS
+
/* Protect from the C stack. This must be the first marking
* done because it provides information about what objects
* are "in-use" by the C code. "in-use" objects are those
@@ -423,6 +405,12 @@ scm_igc (what)
#endif
}
+#else /* USE_THREADS */
+
+ /* Mark every thread's stack and registers */
+ scm_threads_mark_stacks();
+
+#endif /* USE_THREADS */
/* FIXME: insert a phase to un-protect string-data preserved
* in scm_vector_set_length_x.
@@ -432,20 +420,9 @@ scm_igc (what)
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);
+#ifndef USE_THREADS
+ scm_gc_mark (scm_root->handle);
+#endif
scm_mark_weak_vector_spines ();
@@ -453,6 +430,10 @@ scm_igc (what)
--scm_gc_heap_lock;
scm_gc_end ();
+
+#ifdef USE_THREADS
+ SCM_THREAD_CRITICAL_SECTION_END;
+#endif
}
@@ -463,14 +444,9 @@ scm_igc (what)
/* 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;
@@ -525,8 +501,8 @@ gc_mark_nimp:
SCM * vtable_data;
int len;
char * fields_desc;
- SCM * mem;
- int x;
+ register SCM * mem;
+ register int x;
vtable_data = (SCM *)vcell;
layout = vtable_data[scm_struct_i_layout];
@@ -534,9 +510,20 @@ gc_mark_nimp:
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 (len)
+ {
+ for (x = 0; x < len - 2; x += 2, ++mem)
+ if (fields_desc[x] == 'p')
+ scm_gc_mark (*mem);
+ if (fields_desc[x] == 'p')
+ {
+ if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
+ for (x = *mem; x; --x)
+ scm_gc_mark (*++mem);
+ else
+ scm_gc_mark (*mem);
+ }
+ }
if (!SCM_CDR (vcell))
{
SCM_SETGCMARK (vcell);
@@ -743,15 +730,10 @@ gc_mark_nimp:
/* 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;
@@ -812,14 +794,80 @@ scm_mark_locations (x, n)
}
+/* The following is a C predicate which determines if an SCM value can be
+ regarded as a pointer to a cell on the heap. The code is duplicated
+ from scm_mark_locations. */
+
#ifdef __STDC__
-void
-scm_mark_weak_vector_spines (void)
+int
+scm_cellp (SCM value)
#else
-void
-scm_mark_weak_vector_spines ()
+int
+scm_cellp (value)
+ SCM value;
#endif
{
+ register int i, j;
+ register SCM_CELLPTR ptr;
+
+ if SCM_CELLP (*(SCM **) & value)
+ {
+ ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value));
+ i = 0;
+ j = scm_n_heap_segs - 1;
+ if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
+ && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
+ {
+ while (i <= j)
+ {
+ int seg_id;
+ seg_id = -1;
+ if ( (i == j)
+ || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
+ seg_id = i;
+ else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
+ seg_id = j;
+ else
+ {
+ int k;
+ k = (i + j) / 2;
+ if (k == i)
+ break;
+ if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
+ {
+ j = k;
+ ++i;
+ if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
+ continue;
+ else
+ break;
+ }
+ else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
+ {
+ i = k;
+ --j;
+ if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
+ continue;
+ else
+ break;
+ }
+ }
+ if ( !scm_heap_table[seg_id].valid
+ || scm_heap_table[seg_id].valid (ptr,
+ &scm_heap_table[seg_id]))
+ return 1;
+ break;
+ }
+
+ }
+ }
+ return 0;
+}
+
+
+static void
+scm_mark_weak_vector_spines ()
+{
int i;
for (i = 0; i < scm_n_weak; ++i)
@@ -856,13 +904,8 @@ scm_mark_weak_vector_spines ()
-#ifdef __STDC__
-void
-scm_gc_sweep (void)
-#else
void
scm_gc_sweep ()
-#endif
{
register SCM_CELLPTR ptr;
#ifdef SCM_POINTERS_MUNGED
@@ -915,8 +958,8 @@ scm_gc_sweep ()
SCM * mem;
SCM amt;
mem = (SCM *)SCM_CDR (scmptr);
- amt = mem[-2];
- free (mem - 2);
+ amt = mem[- scm_struct_n_extra_words];
+ free (mem - scm_struct_n_extra_words);
m += amt * sizeof (SCM);
}
}
@@ -1215,15 +1258,10 @@ scm_gc_sweep ()
*
* 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;
@@ -1257,17 +1295,12 @@ scm_must_malloc (len, what)
/* 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;
@@ -1297,17 +1330,9 @@ scm_must_realloc (where, olen, len, what)
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);
@@ -1359,17 +1384,12 @@ long scm_heap_size = 0;
*/
-#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
@@ -1450,15 +1470,10 @@ init_heap_seg (seg_org, size, ncells, freelistp)
}
-#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;
@@ -1524,14 +1539,9 @@ alloc_some_heap (ncells, freelistp)
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;
@@ -1571,14 +1581,9 @@ scm_unhash_name (name)
*/
-#ifdef __STDC__
-void
-scm_remember (SCM * ptr)
-#else
void
scm_remember (ptr)
SCM * ptr;
-#endif
{}
#ifdef __STDC__
@@ -1595,14 +1600,9 @@ scm_return_first (elt, va_alist)
}
-#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);
@@ -1612,14 +1612,9 @@ scm_permanent_object (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;
@@ -1665,9 +1660,10 @@ scm_init_storage (init_heap_size)
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_weak_symhash = scm_make_weak_key_hash_table ((SCM) SCM_MAKINUM (scm_symhash_dim));
scm_symhash_vars = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED);
scm_permobjs = SCM_EOL;
+ scm_asyncs = SCM_EOL;
scm_sysintern ("most-positive-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
scm_sysintern ("most-negative-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
#ifdef SCM_BIGDIG
@@ -1677,14 +1673,8 @@ scm_init_storage (init_heap_size)
}
-#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
index 8760811a9..d989b06c7 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
#define SCM_FREEP(x) (SCM_CAR(x)==scm_tc_free_cell)
@@ -69,50 +69,29 @@ 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"
+extern SCM scm_object_addr SCM_P ((SCM obj));
+extern SCM scm_unhash_name SCM_P ((SCM name));
+extern SCM scm_gc_stats SCM_P ((void));
+extern void scm_gc_start SCM_P ((char *what));
+extern void scm_gc_end SCM_P ((void));
+extern SCM scm_gc SCM_P ((void));
+extern void scm_gc_for_alloc SCM_P ((int ncells, SCM * freelistp));
+extern SCM scm_gc_for_newcell SCM_P ((void));
+extern void scm_igc SCM_P ((char *what));
+extern void scm_gc_mark SCM_P ((SCM p));
+extern void scm_mark_locations SCM_P ((SCM_STACKITEM x[], scm_sizet n));
+extern int scm_cellp SCM_P ((SCM value));
+extern void scm_gc_sweep SCM_P ((void));
+extern char * scm_must_malloc SCM_P ((long len, char *what));
+extern char * scm_must_realloc SCM_P ((char *where, long olen, long len,
+ char *what));
+extern void scm_must_free SCM_P ((char *obj));
+extern void scm_remember SCM_P ((SCM * ptr));
+extern SCM scm_return_first SCM_P ((SCM elt, ...));
+extern SCM scm_permanent_object SCM_P ((SCM obj));
+extern SCM scm_protect_object SCM_P ((SCM obj));
+extern SCM scm_unprotect_object SCM_P ((SCM obj));
+extern int scm_init_storage SCM_P ((long init_heap_size));
+extern void scm_init_gc SCM_P ((void));
#endif /* GCH */
diff --git a/libguile/gdb_interface.h b/libguile/gdb_interface.h
new file mode 100644
index 000000000..36a099537
--- /dev/null
+++ b/libguile/gdb_interface.h
@@ -0,0 +1,138 @@
+/* Simple interpreter interface for GDB, the GNU debugger.
+ Copyright (C) 1996 Mikael Djurfeldt.
+
+This file is part of GDB.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+The author can be reached at djurfeldt@nada.kth.se
+Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
+
+/* This is the header file for GDB's interpreter interface. The
+ interpreter must supply definitions of all symbols declared in this
+ file.
+
+ Before including this file, you must #define GDB_TYPE to be the
+ data type used for communication with the interpreter. */
+
+/* The following macro can be used to anchor the symbols of the
+ interface in your main program. This is necessary if the interface
+ is defined in a library, such as Guile. */
+
+#define GDB_INTERFACE \
+void *gdb_interface[] = { \
+ &gdb_options, \
+ &gdb_language, \
+ &gdb_result, \
+ &gdb_output, \
+ &gdb_output_length, \
+ gdb_maybe_valid_type_p, \
+ gdb_read, \
+ gdb_eval, \
+ gdb_print, \
+ gdb_binding \
+}; \
+
+
+/* GDB_OPTIONS is a set of flags informing gdb what features are present
+ in the interface. Currently only one option is supported: */
+
+/* GDB_HAVE_BINDINGS: Set this bit if your interpreter can create new
+ top level bindings on demand (through gdb_top_level_binding) */
+
+#define GDB_HAVE_BINDINGS 1
+
+extern unsigned short gdb_options;
+
+/* GDB_LANGUAGE holds the name of the preferred language mode for this
+ interpreter. For lisp interpreters, the suggested mode is "lisp/c". */
+
+extern char *gdb_language;
+
+/* GDB_RESULT is used for passing results from the interpreter to GDB */
+
+extern GDB_TYPE gdb_result;
+
+/* The interpreter passes strings to GDB in GDB_OUTPUT and
+ GDB_OUTPUT_LENGTH. GDB_OUTPUT should hold the pointer to the
+ string. GDB_OUTPUT_LENGTH should hold its length. The string
+ doesn't need to be terminated by '\0'. */
+
+extern char *gdb_output;
+
+extern int gdb_output_length;
+
+#ifdef __STDC__
+
+/* Return TRUE if the interpreter regards VALUE's type as valid. A
+ lazy implementation is allowed to pass TRUE always. FALSE should
+ only be returned when it is certain that VALUE is not valid.
+
+ In the "lisp/c" language mode, this is used to heuristically
+ discriminate lisp values from C values during printing. */
+
+extern int gdb_maybe_valid_type_p (GDB_TYPE value);
+
+/* Parse expression in string STR. Store result in GDB_RESULT, then
+ return 0 to indicate success. On error, return -1 to indicate
+ failure. An error string can be passed in GDB_OUTPUT and
+ GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero if
+ no message is passed. Please note that the resulting value should
+ be protected against garbage collection. */
+
+extern int gdb_read (char *str);
+
+/* Evaluate expression EXP. Store result in GDB_RESULT, then return 0
+ to indicate success. On error, return -1 to indicate failure. Any
+ output (both on success and failure) can be passed in GDB_OUTPUT
+ and GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero
+ if no output is passed. Please note that the resulting lisp object
+ should be protected against garbage collection. */
+
+extern int gdb_eval (GDB_TYPE exp);
+
+/* Print VALUE. Store output in GDB_OUTPUT and GDB_OUTPUT_LENGTH.
+ Return 0 to indicate success. On error, return -1 to indicate
+ failure. GDB will not look at GDB_OUTPUT or GDB_OUTPUT_LENGTH on
+ failure. Note that this function should be robust against strange
+ values. It could in fact be passed any kind of value. */
+
+extern int gdb_print (GDB_TYPE value);
+
+/* Bind NAME to VALUE in interpreter. (GDB has previously obtained
+ NAME by passing a string to gdb_read.) Return 0 to indicate
+ success or -1 to indicate failure. This feature is optional. GDB
+ will only call this function if the GDB_HAVE_BINDINGS flag is set
+ in gdb_options. Note that GDB may call this function many times
+ for the same name.
+
+ For scheme interpreters, this function should introduce top-level
+ bindings. */
+
+extern int gdb_binding (GDB_TYPE name, GDB_TYPE value);
+
+#else
+
+extern int gdb_maybe_valid_type_p ();
+
+extern int gdb_read ();
+
+extern int gdb_eval ();
+
+extern int gdb_print ();
+
+extern int gdb_binding ();
+
+#endif /* __STDC__ */
diff --git a/libguile/gdbint.c b/libguile/gdbint.c
new file mode 100644
index 000000000..d3b27ec79
--- /dev/null
+++ b/libguile/gdbint.c
@@ -0,0 +1,349 @@
+/* GDB interface for Guile
+ * Copyright (C) 1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+#include <stdio.h>
+#include "_scm.h"
+#include "tag.h"
+#include "strports.h"
+#include "read.h"
+#include "eval.h"
+#include "chars.h"
+
+#include "gdbint.h"
+
+/* {Support for debugging with gdb}
+ *
+ * TODO:
+ *
+ * 1. Redirect outputs
+ * 2. Catch errors
+ * 3. Prevent print from causing segmentation fault when given broken pairs
+ */
+
+#include <stdio.h>
+#include "_scm.h"
+
+#define GDB_TYPE SCM
+
+#include "gdb_interface.h"
+
+
+
+/* Be carefull when this macro is true.
+ scm_gc_heap_lock is set during gc.
+ */
+#define SCM_GC_P (scm_gc_heap_lock)
+
+/* Macros that encapsulate blocks of code which can be called by the
+ * debugger.
+ */
+#define SCM_BEGIN_FOREIGN_BLOCK \
+{ \
+ old_ints = scm_ints_disabled; scm_ints_disabled = 1; \
+ old_gc = scm_block_gc; scm_block_gc = 1; \
+ scm_print_carefully_p = 1; \
+} \
+
+
+#define SCM_END_FOREIGN_BLOCK \
+{ \
+ scm_print_carefully_p = 0; \
+ scm_block_gc = old_gc; \
+ scm_ints_disabled = old_ints; \
+} \
+
+
+#define RESET_STRING { gdb_output_length = 0; }
+
+#define SEND_STRING(str) \
+{ \
+ gdb_output = str; \
+ gdb_output_length = strlen (str); \
+} \
+
+
+/* {Gdb interface}
+ */
+
+unsigned short gdb_options = GDB_HAVE_BINDINGS;
+
+char *gdb_language = "lisp/c";
+
+SCM gdb_result;
+
+char *gdb_output;
+
+int gdb_output_length;
+
+int scm_print_carefully_p;
+
+static SCM gdb_input_port;
+static int port_mark_p, stream_mark_p, string_mark_p;
+
+static SCM tok_buf;
+static int tok_buf_mark_p;
+
+static SCM gdb_output_port;
+static int old_ints, old_gc;
+
+#ifdef __STDC__
+static void
+unmark_port (SCM port)
+#else
+static void
+unmark_port (port)
+ SCM port;
+#endif
+{
+ SCM stream, string;
+ port_mark_p = SCM_GC8MARKP (port);
+ SCM_CLRGC8MARK (port);
+ stream = SCM_STREAM (port);
+ stream_mark_p = SCM_GCMARKP (stream);
+ SCM_CLRGCMARK (stream);
+ string = SCM_CDR (stream);
+ string_mark_p = SCM_GC8MARKP (string);
+ SCM_CLRGC8MARK (string);
+}
+
+#ifdef __STDC__
+static void
+remark_port (SCM port)
+#else
+static void
+remark_port (port)
+ SCM port;
+#endif
+{
+ SCM stream = SCM_STREAM (port);
+ SCM string = SCM_CDR (stream);
+ if (string_mark_p) SCM_SETGC8MARK (string);
+ if (stream_mark_p) SCM_SETGCMARK (stream);
+ if (port_mark_p) SCM_SETGC8MARK (port);
+}
+
+#ifdef __STDC__
+int
+gdb_maybe_valid_type_p (SCM value)
+#else
+int
+gdb_maybe_valid_type_p (value)
+ SCM value;
+#endif
+{
+ if (SCM_IMP (value) || scm_cellp (value))
+ return scm_tag (value) != SCM_MAKINUM (-1);
+ return 0;
+}
+
+#ifdef __STDC__
+int
+gdb_read (char *str)
+#else
+int
+gdb_read (str)
+ char *str;
+#endif
+{
+ SCM ans;
+ int status = 0;
+ RESET_STRING;
+ /* Need to be restrictive about what to read? */
+ if (SCM_GC_P)
+ {
+ char *p;
+ for (p = str; *p != '\0'; ++p)
+ switch (*p)
+ {
+ case '(':
+ case '\'':
+ case '"':
+ SEND_STRING ("Can't read this kind of expressions during gc");
+ return -1;
+ case '#':
+ if (*++p == '\0')
+ goto premature;
+ if (*p == '\\')
+ {
+ if (*++p != '\0')
+ continue;
+ premature:
+ SEND_STRING ("Premature end of lisp expression");
+ return -1;
+ }
+ default:
+ continue;
+ }
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ unmark_port (gdb_input_port);
+ /* Replace string in input port and reset stream */
+ ans = SCM_CDR (SCM_STREAM (gdb_input_port));
+ SCM_SETCHARS (ans, str);
+ SCM_SETLENGTH (ans, strlen (str), scm_tc7_string);
+ SCM_SETCAR (SCM_STREAM (gdb_input_port), SCM_INUM0);
+ /* Read one object */
+ tok_buf_mark_p = SCM_GC8MARKP (tok_buf);
+ SCM_CLRGC8MARK (tok_buf);
+ ans = scm_lreadr (&tok_buf, gdb_input_port, 0, SCM_BOOL_F, &ans);
+ if (SCM_GC_P)
+ {
+ if (SCM_NIMP (ans))
+ {
+ SEND_STRING ("Non-immediate created during gc. Memory may be trashed.");
+ status = -1;
+ goto exit;
+ }
+ }
+ gdb_result = ans;
+ /* Protect answer from future GC */
+ if (SCM_NIMP (ans))
+ scm_permanent_object (ans);
+exit:
+ if (tok_buf_mark_p)
+ SCM_SETGC8MARK (tok_buf);
+ remark_port (gdb_input_port);
+ SCM_END_FOREIGN_BLOCK;
+ return status;
+}
+
+#ifdef __STDC__
+int
+gdb_eval (SCM exp)
+#else
+int
+gdb_eval (exp)
+ SCM exp;
+#endif
+{
+ RESET_STRING;
+ if (SCM_IMP (exp))
+ {
+ gdb_result = exp;
+ return 0;
+ }
+ if (SCM_GC_P)
+ {
+ SEND_STRING ("Can't evaluate lisp expressions during gc");
+ return -1;
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ {
+ SCM env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_thunk_var));
+ gdb_result = scm_permanent_object (scm_ceval (exp, env));
+ }
+ SCM_END_FOREIGN_BLOCK;
+ return 0;
+}
+
+#ifdef __STDC__
+int
+gdb_print (SCM obj)
+#else
+int
+gdb_print (obj)
+ SCM obj;
+#endif
+{
+ RESET_STRING;
+ SCM_BEGIN_FOREIGN_BLOCK;
+ /* Reset stream */
+ SCM_SETCAR (SCM_STREAM (gdb_output_port), SCM_INUM0);
+ scm_write (obj, gdb_output_port);
+ scm_display (SCM_MAKICHR (0), gdb_output_port);
+ SEND_STRING (SCM_CHARS (SCM_CDR (SCM_STREAM (gdb_output_port))));
+ SCM_END_FOREIGN_BLOCK;
+ return 0;
+}
+
+#ifdef __STDC__
+int
+gdb_binding (SCM name, SCM value)
+#else
+int
+gdb_binding (name, value)
+ SCM name;
+ SCM value;
+#endif
+{
+ RESET_STRING;
+ if (SCM_GC_P)
+ {
+ SEND_STRING ("Can't create new bindings during gc");
+ return -1;
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ {
+ SCM vcell = scm_sym2vcell (name,
+ SCM_CDR (scm_top_level_lookup_thunk_var),
+ SCM_BOOL_T);
+ SCM_SETCDR (vcell, value);
+ }
+ SCM_END_FOREIGN_BLOCK;
+ return 0;
+}
+
+void
+scm_init_gdbint ()
+{
+ static char *s = "scm_init_gdb_interface";
+ SCM port;
+
+ scm_print_carefully_p = 0;
+
+ port = scm_mkstrport (SCM_INUM0,
+ scm_make_string (SCM_MAKINUM (80), SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ s);
+ gdb_output_port = scm_permanent_object (port);
+
+ port = scm_mkstrport (SCM_INUM0,
+ scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
+ SCM_OPN | SCM_RDNG,
+ s);
+ gdb_input_port = scm_permanent_object (port);
+
+ tok_buf = scm_permanent_object (scm_makstr (30L, 0));
+}
diff --git a/libguile/gdbint.h b/libguile/gdbint.h
new file mode 100644
index 000000000..5dec69262
--- /dev/null
+++ b/libguile/gdbint.h
@@ -0,0 +1,62 @@
+/* classes: h_files */
+
+#ifndef GDBINTH
+#define GDBINTH
+/* Copyright (C) 1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include "libguile/__scm.h"
+
+
+
+extern int scm_print_carefully_p;
+
+#ifdef __STDC__
+extern void scm_init_gdbint (void);
+#else
+extern void scm_init_gdbint ();
+#endif __STDC__
+
+#endif /* GDBINTH */
diff --git a/libguile/genio.c b/libguile/genio.c
index 6bc082536..815c9ffb3 100644
--- a/libguile/genio.c
+++ b/libguile/genio.c
@@ -42,7 +42,13 @@
#include "extchrs.h"
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "genio.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
@@ -228,7 +234,7 @@ scm_gen_puts (rep, str_data, port)
{
xwchar_t * wstr_data;
- wstr_data = (xwchar_t *)wstr_data;
+ wstr_data = (xwchar_t *) str_data;
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
@@ -345,7 +351,7 @@ scm_gen_write (rep, str_data, nitems, port)
{
xwchar_t * wstr_data;
- wstr_data = (xwchar_t *)wstr_data;
+ wstr_data = (xwchar_t *) str_data;
switch (SCM_PORT_REPRESENTATION (port))
{
case scm_regular_port:
@@ -458,7 +464,6 @@ scm_gen_getc (port)
{
int x;
unsigned char buf[256];
- int c;
SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F,
"huge translation", "scm_gen_puts");
diff --git a/libguile/genio.h b/libguile/genio.h
index 30275211b..ef2fc6b50 100644
--- a/libguile/genio.h
+++ b/libguile/genio.h
@@ -44,8 +44,7 @@
*/
-#include "__scm.h"
-#include "ports.h"
+#include "libguile/__scm.h"
#ifdef __STDC__
diff --git a/libguile/gscm.c b/libguile/gscm.c
index 5eedc9755..994f10219 100644
--- a/libguile/gscm.c
+++ b/libguile/gscm.c
@@ -81,7 +81,7 @@ gscm_portprint_obj (port, obj)
SCM obj;
#endif
{
- scm_iprin1 (obj, port, 1);
+ scm_prin1 (obj, port, 1);
return GSCM_OK;
}
@@ -221,12 +221,12 @@ _eval_port (answer, toplvl, port, printp)
*/
SCM_BASE (scm_rootcont) = (SCM_STACKITEM *) & i;
#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (scm_rootcont) = last_debug_info_frame = 0;
+ SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
#endif
saved_inp = scm_cur_inp;
i = setjmp (SCM_JMPBUF (scm_rootcont));
-#ifdef SCM_STACK_CHECK
- scm_check_stack_p = 1;
+#ifdef STACK_CHECKING
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif
if (!i)
{
@@ -588,6 +588,7 @@ gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd)
scm_init_throw ();
scm_init_variable ();
scm_init_vectors ();
+ scm_init_version ();
scm_init_weaks ();
scm_init_vports ();
scm_init_eval ();
diff --git a/libguile/gscm.h b/libguile/gscm.h
index c6ac44b5f..e35f6e8b5 100644
--- a/libguile/gscm.h
+++ b/libguile/gscm.h
@@ -201,7 +201,7 @@
/* {I/O}
*/
-#define gscm_print_obj scm_iprin1
+#define gscm_print_obj scm_prin1
#define gscm_putc scm_putc
#define gscm_puts scm_puts
#define gscm_fwrite scm_fwrite
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 2f1cc75e9..4dd37a331 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -42,7 +42,9 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "gsubr.h"
/*
* gsubr.c
@@ -128,7 +130,7 @@ scm_gsubr_apply(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))));
+ scm_wrong_num_args (SCM_SNAME(GSUBR_PROC(self)));
#endif
v[i] = SCM_CAR(args);
args = SCM_CDR(args);
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 4aed7ef0a..9c9785227 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
#ifdef __STDC__
diff --git a/libguile/hash.c b/libguile/hash.c
index 48f171a61..f1739ecbd 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -42,7 +42,9 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "hash.h"
#ifndef floor
diff --git a/libguile/hash.h b/libguile/hash.h
index 8c53d3696..c599c95f0 100644
--- a/libguile/hash.h
+++ b/libguile/hash.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
#ifdef __STDC__
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index fd37e2574..132edca78 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -42,7 +42,11 @@
#include <stdio.h>
#include "_scm.h"
+#include "alist.h"
+#include "hash.h"
+#include "eval.h"
+#include "hashtab.h"
#ifdef __STDC__
diff --git a/libguile/hashtab.h b/libguile/hashtab.h
index 345303896..2cd7577f4 100644
--- a/libguile/hashtab.h
+++ b/libguile/hashtab.h
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-
+#include "libguile/__scm.h"
#ifdef __STDC__
diff --git a/libguile/init.c b/libguile/init.c
index 2f65c15f6..05dee5ccc 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -43,25 +43,96 @@
#include <stdio.h>
#include "_scm.h"
+/* Everybody has an init function. */
+#include "alist.h"
+#include "append.h"
+#include "arbiters.h"
+#include "async.h"
+#include "boolean.h"
+#include "chars.h"
+#include "continuations.h"
+#ifdef DEBUG_EXTENSIONS
+#include "debug.h"
+#endif
+#include "dynwind.h"
+#include "eq.h"
+#include "error.h"
+#include "eval.h"
+#include "fdsocket.h"
+#include "feature.h"
+#include "filesys.h"
+#include "fports.h"
+#include "gc.h"
+#include "gdbint.h"
+#include "gsubr.h"
+#include "hash.h"
+#include "hashtab.h"
+#include "ioext.h"
+#include "kw.h"
+#include "list.h"
+#include "load.h"
+#include "mallocs.h"
+#include "mbstrings.h"
+#include "numbers.h"
+#include "objprop.h"
+#include "options.h"
+#include "pairs.h"
+#include "ports.h"
+#include "posix.h"
+#include "print.h"
+#include "procprop.h"
+#include "procs.h"
+#include "ramap.h"
+#include "read.h"
+#include "scmsigs.h"
+#include "sequences.h"
+#include "simpos.h"
+#include "smob.h"
+#include "socket.h"
+#include "srcprop.h"
+#include "stackchk.h"
+#include "stime.h"
+#include "strings.h"
+#include "strop.h"
+#include "strorder.h"
+#include "strports.h"
+#include "struct.h"
+#include "symbols.h"
+#include "tag.h"
+#include "throw.h"
+#include "unif.h"
+#include "variable.h"
+#include "vectors.h"
+#include "version.h"
+#include "vports.h"
+#include "weaks.h"
+
+#include "init.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
-#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
{
+ SCM root;
struct scm_port_table * pt;
+ root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
+ scm_set_root (SCM_ROOT_STATE (root));
+
scm_stack_base = base;
- /* Create standar ports from stdio files, if requested to do so.
+ /* Create standard ports from stdio files, if requested to do so.
*/
if (!in)
@@ -127,6 +198,7 @@ scm_start_stack (base, in, out, err)
SCM_NEWCELL (scm_rootcont);
SCM_SETJMPBUF (scm_rootcont, scm_must_malloc ((long) sizeof (regs), "continuation"));
SCM_CAR (scm_rootcont) = scm_tc7_contin;
+ SCM_SEQ (scm_rootcont) = 0;
/* The root continuation if further initialized by scm_restart_stack. */
/* Create the look-aside stack for variables that are shared between
@@ -142,18 +214,16 @@ scm_start_stack (base, in, out, err)
}
-#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;
+#ifdef DEBUG_EXTENSIONS
+ SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
+#endif
SCM_BASE (scm_rootcont) = base;
scm_continuation_stack_ptr = SCM_MAKINUM (0);
}
@@ -229,7 +299,7 @@ typedef long setjmp_type;
* 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
+ * If NULL is passed, your "initfunc" should set up the
* standard ports.
*
* boot_cmd is a string containing a Scheme expression to evaluate
@@ -242,27 +312,48 @@ typedef long setjmp_type;
* 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.
+ * 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
+static int scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base,
+ char **result,
+ int argc, char **argv,
+ FILE *in, FILE *out, FILE *err,
+ void (*init_func) (),
+ char *boot_cmd));
+
int
-scm_boot_guile (result, argc, argv, in, out, err, boot_cmd)
+scm_boot_guile (result, argc, argv, in, out, err, init_func, boot_cmd)
char ** result;
int argc;
char ** argv;
FILE * in;
FILE * out;
FILE * err;
+ void (*init_func) ();
+ char * boot_cmd;
+{
+ SCM_STACKITEM dummy;
+
+ return scm_boot_guile_1 (&dummy, result, argc, argv, in, out, err,
+ init_func, boot_cmd);
+}
+
+static int
+scm_boot_guile_1 (base, result, argc, argv, in, out, err, init_func, boot_cmd)
+ SCM_STACKITEM *base;
+ char ** result;
+ int argc;
+ char ** argv;
+ FILE * in;
+ FILE * out;
+ FILE * err;
+ void (*init_func) ();
char * boot_cmd;
-#endif
{
static int initialized = 0;
static int live = 0;
- SCM_STACKITEM i;
setjmp_type setjmp_val;
int stat;
@@ -278,7 +369,7 @@ scm_boot_guile (result, argc, argv, in, out, err, boot_cmd)
if (initialized)
{
- scm_restart_stack (&i);
+ scm_restart_stack (base);
}
else
{
@@ -286,7 +377,11 @@ scm_boot_guile (result, argc, argv, in, out, err, boot_cmd)
scm_smob_prehistory ();
scm_tables_prehistory ();
scm_init_storage (0);
- scm_start_stack (&i, in, out, err);
+ scm_init_root ();
+#ifdef USE_THREADS
+ scm_init_threads (base);
+#endif
+ scm_start_stack (base, in, out, err);
scm_init_gsubr ();
scm_init_feature ();
scm_init_alist ();
@@ -296,14 +391,17 @@ scm_boot_guile (result, argc, argv, in, out, err, boot_cmd)
scm_init_boolean ();
scm_init_chars ();
scm_init_continuations ();
+#ifdef DEBUG_EXTENSIONS
+ scm_init_debug ();
+#endif
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_gdbint ();
scm_init_hash ();
scm_init_hashtab ();
scm_init_ioext ();
@@ -312,21 +410,28 @@ scm_boot_guile (result, argc, argv, in, out, err, boot_cmd)
scm_init_mallocs ();
scm_init_numbers ();
scm_init_objprop ();
+#if DEBUG_EXTENSIONS
+ /* Excluding this until it's really needed makes the binary
+ * smaller after linking. */
+ scm_init_options ();
+#endif
scm_init_pairs ();
scm_init_ports ();
scm_init_posix ();
scm_init_procs ();
scm_init_procprop ();
- scm_init_rgx ();
scm_init_scmsigs ();
scm_init_socket ();
+#ifdef DEBUG_EXTENSIONS
+ scm_init_srcprop ();
+#endif
scm_init_stackchk ();
scm_init_strports ();
- scm_init_struct ();
scm_init_symbols ();
scm_init_tag ();
scm_init_load ();
- scm_init_print ();
+ scm_init_struct ();
+ scm_init_print (); /* Requires struct */
scm_init_read ();
scm_init_sequences ();
scm_init_stime ();
@@ -337,14 +442,15 @@ scm_boot_guile (result, argc, argv, in, out, err, boot_cmd)
scm_init_throw ();
scm_init_variable ();
scm_init_vectors ();
+ scm_init_version ();
scm_init_weaks ();
scm_init_vports ();
scm_init_eval ();
scm_init_ramap ();
scm_init_unif ();
scm_init_simpos ();
- scm_appinit ();
scm_progargs = scm_makfromstrs (argc, argv);
+ scm_init_load_path ();
initialized = 1;
}
@@ -358,11 +464,19 @@ scm_boot_guile (result, argc, argv, in, out, err, boot_cmd)
setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
+#ifdef STACK_CHECKING
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+#endif
if (!setjmp_val)
{
- SCM last;
+ SCM last = SCM_UNDEFINED;
scm_init_signals ();
+ /* Call the initialization function passed in by the user, if
+ present. */
+ if (init_func) (*init_func) ();
+
+ /* Evaluate boot_cmd string. */
{
SCM p;
SCM form;
diff --git a/libguile/init.h b/libguile/init.h
index a20262104..083259648 100644
--- a/libguile/init.h
+++ b/libguile/init.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -58,18 +58,13 @@ enum scm_boot_status
-#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 */
-
-
-
-
+extern void scm_start_stack SCM_P ((void *base,
+ FILE *in, FILE *out, FILE *err));
+extern void scm_restart_stack SCM_P ((void * base));
+extern int scm_boot_guile SCM_P ((char **result,
+ int argc, char **argv,
+ FILE *in, FILE *out, FILE *err,
+ void (*init_func) (),
+ char *boot_cmd));
#endif /* INITH */
diff --git a/libguile/ioext.c b/libguile/ioext.c
index d51b9a09d..9f1959c39 100644
--- a/libguile/ioext.c
+++ b/libguile/ioext.c
@@ -42,13 +42,21 @@
#include <stdio.h>
-#include <unistd.h>
#include "fd.h"
#include "_scm.h"
+#include "fports.h"
+
+#include "ioext.h"
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
-SCM_PROC (s_sys_ftell, "%ftell", 1, 0, 0, scm_sys_ftell);
+SCM_PROC (s_sys_ftell, "ftell", 1, 0, 0, scm_sys_ftell);
#ifdef __STDC__
SCM
scm_sys_ftell (SCM port)
@@ -62,7 +70,7 @@ scm_sys_ftell (port)
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;
+ scm_syserror (s_sys_ftell);
if (pos > 0 && SCM_CRDYP (port))
pos--;
return SCM_MAKINUM (pos);
@@ -70,7 +78,7 @@ scm_sys_ftell (port)
-SCM_PROC (s_sys_fseek, "%fseek", 3, 0, 0, scm_sys_fseek);
+SCM_PROC (s_sys_fseek, "fseek", 3, 0, 0, scm_sys_fseek);
#ifdef __STDC__
SCM
scm_sys_fseek (SCM port, SCM offset, SCM whence)
@@ -90,12 +98,14 @@ scm_sys_fseek (port, offset, whence)
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;
+ if (rv != 0)
+ scm_syserror (s_sys_fseek);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_freopen, "%freopen", 3, 0, 0, scm_sys_freopen);
+SCM_PROC (s_sys_freopen, "freopen", 3, 0, 0, scm_sys_freopen);
#ifdef __STDC__
SCM
scm_sys_freopen (SCM filename, SCM modes, SCM port)
@@ -134,7 +144,7 @@ scm_sys_freopen (filename, modes, port)
-SCM_PROC (s_sys_duplicate_port, "%duplicate-port", 2, 0, 0, scm_sys_duplicate_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)
@@ -155,22 +165,15 @@ scm_sys_duplicate_port (oldpt, modes)
SCM_DEFER_INTS;
oldfd = fileno ((FILE *)SCM_STREAM (oldpt));
if (oldfd == -1)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- };
+ scm_syserror (s_sys_duplicate_port);
SCM_SYSCALL (newfd = dup (oldfd));
if (newfd == -1)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- };
+ scm_syserror (s_sys_duplicate_port);
f = fdopen (newfd, SCM_CHARS (modes));
if (!f)
{
SCM_SYSCALL (close (newfd));
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
+ scm_syserror (s_sys_duplicate_port);
}
{
struct scm_port_table * pt;
@@ -187,7 +190,7 @@ scm_sys_duplicate_port (oldpt, modes)
-SCM_PROC (s_sys_redirect_port, "%redirect-port", 2, 0, 0, scm_sys_redirect_port);
+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)
@@ -203,16 +206,19 @@ scm_sys_redirect_port (into_pt, from_pt)
SCM_ASSERT (SCM_NIMP (into_pt) && SCM_OPPORTP (into_pt), into_pt, SCM_ARG1, s_sys_redirect_port);
SCM_ASSERT (SCM_NIMP (from_pt) && SCM_OPPORTP (from_pt), from_pt, SCM_ARG2, s_sys_redirect_port);
oldfd = fileno ((FILE *)SCM_STREAM (into_pt));
+ if (oldfd == -1)
+ scm_syserror (s_sys_redirect_port);
newfd = fileno ((FILE *)SCM_STREAM (from_pt));
- if (oldfd == -1 || newfd == -1)
- ans = -1;
- else
- SCM_SYSCALL (ans = dup2 (oldfd, newfd));
+ if (newfd == -1)
+ scm_syserror (s_sys_redirect_port);
+ SCM_SYSCALL (ans = dup2 (oldfd, newfd));
+ if (ans == -1)
+ scm_syserror (s_sys_redirect_port);
SCM_ALLOW_INTS;
- return (ans == -1) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_fileno, "%fileno", 1, 0, 0, scm_sys_fileno);
+SCM_PROC (s_sys_fileno, "fileno", 1, 0, 0, scm_sys_fileno);
#ifdef __STDC__
SCM
scm_sys_fileno (SCM port)
@@ -225,33 +231,12 @@ scm_sys_fileno (port)
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);
+ if (fd == -1)
+ scm_syserror (s_sys_fileno);
+ return SCM_MAKINUM (fd);
}
-
-
-SCM_PROC (s_sys_isatty, "%isatty?", 1, 0, 0, scm_sys_isatty_p);
+SCM_PROC (s_sys_isatty, "isatty?", 1, 0, 0, scm_sys_isatty_p);
#ifdef __STDC__
SCM
scm_sys_isatty_p (SCM port)
@@ -265,17 +250,14 @@ scm_sys_isatty_p (port)
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_syserror (s_sys_isatty);
+ rv = isatty (rv);
+ return rv ? SCM_BOOL_T : SCM_BOOL_F;
}
-SCM_PROC (s_sys_fdopen, "%fdopen", 2, 0, 0, scm_sys_fdopen);
+SCM_PROC (s_sys_fdopen, "fdopen", 2, 0, 0, scm_sys_fdopen);
#ifdef __STDC__
SCM
scm_sys_fdopen (SCM fdes, SCM modes)
@@ -288,20 +270,21 @@ scm_sys_fdopen (fdes, modes)
{
FILE *f;
SCM port;
+ struct scm_port_table * pt;
SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_sys_fdopen);
SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_fdopen);
+ SCM_NEWCELL (port);
SCM_DEFER_INTS;
f = fdopen (SCM_INUM (fdes), SCM_CHARS (modes));
if (f == NULL)
- {
- SCM_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_syserror (s_sys_fdopen);
+ pt = scm_add_to_port_table (port);
+ SCM_SETPTAB_ENTRY (port, pt);
+ if (SCM_BUF0 & (SCM_CAR (port) = scm_tc16_fport
+ | scm_mode_bits (SCM_CHARS (modes))))
+ scm_setbuf0 (port);
+ SCM_SETSTREAM (port, (SCM)f);
SCM_ALLOW_INTS;
return port;
}
@@ -309,12 +292,11 @@ scm_sys_fdopen (fdes, modes)
/* 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.
+ * Returns #f if fdes is already the given value.
+ * #t if fdes moved.
* MOVE->FDES is implemented in Scheme and calls this primitive.
*/
-SCM_PROC (s_sys_primitive_move_to_fdes, "%primitive-move->fdes", 2, 0, 0, scm_sys_primitive_move_to_fdes);
+SCM_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)
@@ -339,24 +321,18 @@ scm_sys_primitive_move_to_fdes (port, fd)
if (old_fd == new_fd)
{
SCM_ALLOW_INTS;
- return SCM_MAKINUM (0);
+ return SCM_BOOL_F;
}
scm_evict_ports (new_fd);
rv = dup2 (old_fd, new_fd);
if (rv == -1)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
+ scm_syserror (s_sys_primitive_move_to_fdes);
scm_setfileno (stream, new_fd);
SCM_SYSCALL (close (old_fd));
SCM_ALLOW_INTS;
- return SCM_MAKINUM (1);
+ return SCM_BOOL_T;
}
-
-
-/* FIXME */
#ifdef __STDC__
void
scm_setfileno (FILE *fs, int fd)
@@ -450,12 +426,6 @@ scm_init_ioext ()
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));
diff --git a/libguile/ioext.h b/libguile/ioext.h
index b7a30e2c0..9294f2223 100644
--- a/libguile/ioext.h
+++ b/libguile/ioext.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -57,7 +57,7 @@ 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_isatty_p (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);
@@ -72,7 +72,7 @@ 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_isatty_p ();
extern SCM scm_sys_fdopen ();
extern SCM scm_sys_primitive_move_to_fdes ();
extern void scm_setfileno ();
diff --git a/libguile/kw.c b/libguile/kw.c
index e559ef3ea..3bf6ba63a 100644
--- a/libguile/kw.c
+++ b/libguile/kw.c
@@ -42,7 +42,11 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "mbstrings.h"
+#include "smob.h"
+#include "kw.h"
#ifdef __STDC__
@@ -59,13 +63,13 @@ free_kw (obj)
#ifdef __STDC__
static int
-prin_kw (SCM exp, SCM port, int writing)
+prin_kw (SCM exp, SCM port, scm_print_state *pstate)
#else
static int
-prin_kw (exp, port, writing)
+prin_kw (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
scm_gen_puts (scm_regular_string, ":", port);
diff --git a/libguile/kw.h b/libguile/kw.h
index c84899cff..6cec7f659 100644
--- a/libguile/kw.h
+++ b/libguile/kw.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/libguile.h b/libguile/libguile.h
index ea18a23db..824795864 100644
--- a/libguile/libguile.h
+++ b/libguile/libguile.h
@@ -45,89 +45,82 @@
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-# ifdef AMIGA
-# include <stddef.h>
-# endif /* def AMIGA */
-# define scm_sizet size_t
-#else
-# ifdef _SIZE_T
-# define scm_sizet size_t
-# else
-# define scm_sizet unsigned int
-# endif /* def _SIZE_T */
-#endif /* def STDC_HEADERS */
+#include "libguile/__scm.h"
-#include "__scm.h"
+/* These files define typedefs used by later files, so they need to
+ come first. */
+#include "libguile/print.h"
+#include "libguile/smob.h"
+#include "libguile/pairs.h"
-#include "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"
+#include "libguile/alist.h"
+#include "libguile/append.h"
+#include "libguile/arbiters.h"
+#include "libguile/async.h"
+#include "libguile/boolean.h"
+#include "libguile/chars.h"
+#include "libguile/continuations.h"
+#ifdef DEBUG_EXTENSIONS
+#include "libguile/debug.h"
+#endif
+#include "libguile/dynwind.h"
+#include "libguile/eq.h"
+#include "libguile/error.h"
+#include "libguile/eval.h"
+#include "libguile/extchrs.h"
+#include "libguile/fdsocket.h"
+#include "libguile/feature.h"
+#include "libguile/filesys.h"
+#include "libguile/fports.h"
+#include "libguile/gc.h"
+#include "libguile/gdbint.h"
+#include "libguile/genio.h"
+#include "libguile/gsubr.h"
+#include "libguile/hash.h"
+#include "libguile/hashtab.h"
+#include "libguile/init.h"
+#include "libguile/ioext.h"
+#include "libguile/kw.h"
+#include "libguile/list.h"
+#include "libguile/load.h"
+#include "libguile/mallocs.h"
+#include "libguile/markers.h"
+#include "libguile/mbstrings.h"
+#include "libguile/numbers.h"
+#include "libguile/objprop.h"
+#include "libguile/options.h"
+#include "libguile/ports.h"
+#include "libguile/posix.h"
+#include "libguile/procprop.h"
+#include "libguile/procs.h"
+#include "libguile/ramap.h"
+#include "libguile/read.h"
+#include "libguile/root.h"
+#include "libguile/scmsigs.h"
+#include "libguile/sequences.h"
+#include "libguile/simpos.h"
+#include "libguile/socket.h"
+#include "libguile/srcprop.h"
+#include "libguile/stackchk.h"
+#include "libguile/stime.h"
+#include "libguile/strings.h"
+#include "libguile/strop.h"
+#include "libguile/strorder.h"
+#include "libguile/strports.h"
+#include "libguile/struct.h"
+#include "libguile/symbols.h"
+#include "libguile/tag.h"
+#include "libguile/tags.h"
+#include "libguile/throw.h"
+#include "libguile/unif.h"
+#include "libguile/variable.h"
+#include "libguile/vectors.h"
+#include "libguile/version.h"
+#include "libguile/vports.h"
+#include "libguile/weaks.h"
+#ifdef USE_THREADS
+#include "libguile/../threads/threads.h"
+#endif
diff --git a/libguile/list.c b/libguile/list.c
index 15c20fd32..bb38ddfc5 100644
--- a/libguile/list.c
+++ b/libguile/list.c
@@ -41,6 +41,9 @@
#include <stdio.h>
#include "_scm.h"
+#include "eq.h"
+
+#include "list.h"
#ifdef __STDC__
#include <stdarg.h>
@@ -51,8 +54,9 @@
#endif
+/* creating lists */
-
+/* SCM_P won't help us deal with varargs here. */
#ifdef __STDC__
SCM
scm_listify (SCM elt, ...)
@@ -61,7 +65,6 @@ SCM
scm_listify (elt, va_alist)
SCM elt;
va_dcl
-
#endif
{
va_list foo;
@@ -82,14 +85,9 @@ scm_listify (elt, va_alist)
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;
}
@@ -97,29 +95,20 @@ scm_list(objs)
+/* general questions about lists --- null?, list?, length, etc. */
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;
@@ -128,41 +117,41 @@ scm_list_p(x)
}
-#ifdef __STDC__
-long
-scm_ilength(SCM sx)
-#else
+/* Return the length of SX, or -1 if it's not a proper list.
+ This uses the "tortise and hare" algorithm to detect "infinitely
+ long" lists (i.e. lists with cycles in their cdrs), and returns -1
+ if it does find one. */
long
scm_ilength(sx)
SCM sx;
-#endif
{
register long i = 0;
- register SCM x = sx;
+ register SCM tortise = sx;
+ register SCM hare = sx;
+
do {
- if SCM_IMP(x) return SCM_NULLP(x) ? i : -1;
- if SCM_NCONSP(x) return -1;
- x = SCM_CDR(x);
+ if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1;
+ if SCM_NCONSP(hare) return -1;
+ hare = SCM_CDR(hare);
i++;
- if SCM_IMP(x) return SCM_NULLP(x) ? i : -1;
- if SCM_NCONSP(x) return -1;
- x = SCM_CDR(x);
+ if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1;
+ if SCM_NCONSP(hare) return -1;
+ hare = SCM_CDR(hare);
i++;
- sx = SCM_CDR(sx);
+ /* For every two steps the hare takes, the tortise takes one. */
+ tortise = SCM_CDR(tortise);
}
- while (x != sx);
+ while (hare != tortise);
+
+ /* If the tortise ever catches the hare, then the list must contain
+ a cycle. */
return -1;
}
SCM_PROC(s_list_length, "list-length", 1, 0, 0, scm_list_length);
-#ifdef __STDC__
-SCM
-scm_list_length(SCM x)
-#else
SCM
scm_list_length(x)
SCM x;
-#endif
{
int i;
i = scm_ilength(x);
@@ -172,16 +161,12 @@ scm_list_length(x)
+/* appending lists */
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;
@@ -210,14 +195,9 @@ scm_list_append(args)
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:
@@ -232,18 +212,37 @@ scm_list_append_x(args)
}
-
+SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair);
+SCM
+scm_last_pair(sx)
+ SCM sx;
+{
+ register SCM res = sx;
+ register SCM x;
+ if (SCM_NULLP (sx))
+ return SCM_EOL;
+
+ SCM_ASSERT(SCM_NIMP(res) && SCM_CONSP(res), res, SCM_ARG1, s_last_pair);
+ while (!0) {
+ x = SCM_CDR(res);
+ if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
+ res = x;
+ x = SCM_CDR(res);
+ if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
+ res = x;
+ sx = SCM_CDR(sx);
+ SCM_ASSERT(x != sx, sx, SCM_ARG1, s_last_pair);
+ }
+}
+
+
+/* reversing lists */
SCM_PROC (s_list_reverse, "list-reverse", 1, 0, 0, scm_list_reverse);
-#ifdef __STDC__
-SCM
-scm_list_reverse(SCM lst)
-#else
SCM
scm_list_reverse(lst)
SCM lst;
-#endif
{
SCM res = SCM_EOL;
SCM p = lst;
@@ -256,15 +255,10 @@ scm_list_reverse(lst)
}
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)
@@ -286,18 +280,13 @@ scm_list_reverse_x (lst, newtail)
-
+/* indexing lists by element number */
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);
@@ -313,16 +302,11 @@ erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(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);
@@ -339,18 +323,30 @@ erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
}
+SCM_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
+SCM_PROC(s_list_tail, "list-tail", 2, 0, 0, scm_list_tail);
+SCM
+scm_list_tail(lst, k)
+ SCM lst;
+ SCM k;
+{
+ register long i;
+ SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_tail);
+ i = SCM_INUM(k);
+ while (i-- > 0) {
+ SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_tail);
+ lst = SCM_CDR(lst);
+ }
+ return lst;
+}
+
SCM_PROC(s_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x);
-#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);
@@ -368,71 +364,13 @@ erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
-
-
-
-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;
-}
-
+/* copying lists, perhaps partially */
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;
@@ -453,33 +391,50 @@ scm_list_head(lst, k)
}
+SCM_PROC (s_list_copy, "list-copy", 1, 0, 0, scm_list_copy);
+SCM
+scm_list_copy (lst)
+ SCM lst;
+{
+ SCM newlst;
+ SCM * fill_here;
+ SCM from_here;
+
+ newlst = SCM_EOL;
+ fill_here = &newlst;
+ from_here = lst;
+
+ while (SCM_NIMP (from_here) && SCM_CONSP (from_here))
+ {
+ SCM c;
+ c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
+ *fill_here = c;
+ fill_here = &SCM_CDR (c);
+ from_here = SCM_CDR (from_here);
+ }
+ return newlst;
+}
+
+/* membership tests (memq, memv, etc.) */
+
+static void sloppy_mem_check SCM_P ((SCM obj, char * where, char * why));
-#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))
{
@@ -491,15 +446,10 @@ scm_sloppy_memq(x, 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))
{
@@ -511,15 +461,10 @@ scm_sloppy_memv(x, 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))
{
@@ -532,72 +477,53 @@ scm_sloppy_member (x, 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;
+ return (answer == SCM_EOL) ? SCM_BOOL_F : 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;
+ return (answer == SCM_EOL) ? SCM_BOOL_F : 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;
+ return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
}
+/* deleting elements from a list (delq, etc.) */
SCM_PROC(s_delq_x, "delq!", 2, 0, 0, scm_delq_x);
-#ifdef __STDC__
-SCM
-scm_delq_x (SCM item, SCM lst)
-#else
SCM
scm_delq_x (item, lst)
SCM item;
SCM lst;
-#endif
{
SCM start;
@@ -623,15 +549,10 @@ scm_delq_x (item, lst)
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;
@@ -658,15 +579,10 @@ scm_delv_x (item, lst)
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;
@@ -693,47 +609,12 @@ scm_delete_x (item, lst)
-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;
@@ -742,15 +623,10 @@ scm_delq (item, lst)
}
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;
@@ -759,15 +635,10 @@ scm_delv (item, lst)
}
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;
@@ -777,15 +648,8 @@ scm_delete (item, lst)
-
-#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
index ab0555540..82d560673 100644
--- a/libguile/list.h
+++ b/libguile/list.h
@@ -44,83 +44,39 @@
*/
-#include "__scm.h"
+#include "libguile/__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 */
-
-
-
-
-
-
+extern SCM scm_list_head SCM_P ((SCM lst, SCM k));
+extern SCM scm_listify SCM_P ((SCM elt, ...));
+extern SCM scm_list SCM_P ((SCM objs));
+extern SCM scm_null_p SCM_P ((SCM x));
+extern SCM scm_list_p SCM_P ((SCM x));
+extern long scm_ilength SCM_P ((SCM sx));
+extern SCM scm_list_length SCM_P ((SCM x));
+extern SCM scm_list_append SCM_P ((SCM args));
+extern SCM scm_list_append_x SCM_P ((SCM args));
+extern SCM scm_list_reverse SCM_P ((SCM lst));
+extern SCM scm_list_reverse_x SCM_P ((SCM lst, SCM newtail));
+extern SCM scm_list_ref SCM_P ((SCM lst, SCM k));
+extern SCM scm_list_set_x SCM_P ((SCM lst, SCM k, SCM val));
+extern SCM scm_list_cdr_ref SCM_P ((SCM lst, SCM k));
+extern SCM scm_list_cdr_set_x SCM_P ((SCM lst, SCM k, SCM val));
+extern SCM scm_last_pair SCM_P ((SCM sx));
+extern SCM scm_list_tail SCM_P ((SCM lst, SCM k));
+extern SCM scm_sloppy_memq SCM_P ((SCM x, SCM lst));
+extern SCM scm_sloppy_memv SCM_P ((SCM x, SCM lst));
+extern SCM scm_sloppy_member SCM_P ((SCM x, SCM lst));
+extern SCM scm_memq SCM_P ((SCM x, SCM lst));
+extern SCM scm_memv SCM_P ((SCM x, SCM lst));
+extern SCM scm_member SCM_P ((SCM x, SCM lst));
+extern SCM scm_delq_x SCM_P ((SCM item, SCM lst));
+extern SCM scm_delv_x SCM_P ((SCM item, SCM lst));
+extern SCM scm_delete_x SCM_P ((SCM item, SCM lst));
+extern SCM scm_list_copy SCM_P ((SCM lst));
+extern SCM scm_delq SCM_P ((SCM item, SCM lst));
+extern SCM scm_delv SCM_P ((SCM item, SCM lst));
+extern SCM scm_delete SCM_P ((SCM item, SCM lst));
+extern void scm_init_list SCM_P ((void));
#endif /* LISTH */
diff --git a/libguile/load.c b/libguile/load.c
index b2a54d79a..f0390ec25 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -42,50 +42,186 @@
#include <stdio.h>
#include "_scm.h"
+#include "libpath.h"
+#include "fports.h"
+#include "read.h"
+#include "eval.h"
+
+#include "load.h"
+
+#include <sys/types.h>
+#include <sys/stat.h>
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif /* HAVE_UNISTD_H */
+
+#ifndef R_OK
+#define R_OK 4
+#endif
+/* Loading a file, given an absolute filename. */
-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_PROC(s_sys_try_load, "primitive-load", 1, 2, 0, scm_sys_try_load);
SCM
-scm_sys_try_load (filename, case_insensative_p, sharp)
+scm_sys_try_load (filename, case_insensitive_p, sharp)
SCM filename;
- SCM case_insensative_p;
+ SCM case_insensitive_p;
SCM sharp;
-#endif
{
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_sys_try_load);
+ 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);
+ form = scm_read (port, case_insensitive_p, sharp);
if (SCM_EOF_VAL == form)
break;
scm_eval_x (form);
}
scm_close_port (port);
}
- return SCM_BOOL_T;
+ return SCM_UNSPECIFIED;
}
+/* Initializing the load path, and searching it. */
+
+static SCM *scm_loc_load_path;
-#ifdef __STDC__
+/* Initialize the global variable %load-path, given the value of the
+ LIBRARY_PATH preprocessor symbol and the SCHEME_LOAD_PATH
+ environment variable. */
void
-scm_init_load (void)
-#else
+scm_init_load_path ()
+{
+ SCM path = SCM_EOL;
+
+#ifdef LIBRARY_PATH
+ path = scm_cons (scm_makfrom0str (LIBRARY_PATH), path);
+#endif /* LIBRARY_PATH */
+
+ {
+ char *path_string = getenv ("SCHEME_LOAD_PATH");
+
+ if (path_string && path_string[0] != '\0')
+ {
+ char *scan, *elt_end;
+
+ /* Scan backwards from the end of the string, to help
+ construct the list in the right order. */
+ scan = elt_end = path_string + strlen (path_string);
+ do {
+ /* Scan back to the beginning of the current element. */
+ do scan--;
+ while (scan >= path_string && *scan != ':');
+ path = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0),
+ path);
+ elt_end = scan;
+ } while (scan >= path_string);
+ }
+ }
+
+ *scm_loc_load_path = path;
+}
+
+
+/* Search %load-path for a directory containing a file named FILENAME.
+ The file must be readable, and not a directory.
+ If we find one, return its full filename; otherwise, return #f. */
+SCM_PROC(s_sys_search_load_path, "%search-load-path", 1, 0, 0, scm_sys_search_load_path);
+SCM
+scm_sys_search_load_path (filename)
+ SCM filename;
+{
+ SCM path = *scm_loc_load_path;
+ char *buf;
+ int buf_size;
+ int filename_len;
+
+ SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
+ SCM_ARG1, s_sys_search_load_path);
+ filename_len = SCM_ROLENGTH (filename);
+
+ SCM_DEFER_INTS;
+
+ buf_size = 80;
+ buf = scm_must_malloc (buf_size, s_sys_search_load_path);
+
+ while (SCM_NIMP (path) && SCM_CONSP (path))
+ {
+ SCM elt = SCM_CAR (path);
+ if (SCM_NIMP (elt) && SCM_ROSTRINGP (elt))
+ {
+ int len = SCM_ROLENGTH (elt) + 1 + filename_len;
+
+ if (len + 1 > buf_size)
+ {
+ int old_size = buf_size;
+ buf_size = len + 50;
+ buf = scm_must_realloc (buf, old_size, buf_size,
+ s_sys_search_load_path);
+ }
+
+ memcpy (buf, SCM_ROCHARS (elt), SCM_ROLENGTH (elt));
+ buf[SCM_ROLENGTH (elt)] = '/';
+ memcpy (buf + SCM_ROLENGTH (elt) + 1,
+ SCM_ROCHARS (filename), filename_len);
+ buf[len] = '\0';
+
+ {
+ struct stat mode;
+
+ if (stat (buf, &mode) >= 0
+ && ! (mode.st_mode & S_IFDIR)
+ && access (buf, R_OK) == 0)
+ {
+ SCM result = scm_makfromstr (buf, len, 0);
+ scm_must_free (buf);
+ SCM_ALLOW_INTS;
+ return result;
+ }
+ }
+ }
+
+ path = SCM_CDR (path);
+ }
+
+ scm_must_free (buf);
+ SCM_ALLOW_INTS;
+ return SCM_BOOL_F;
+}
+
+
+SCM_PROC(s_sys_try_load_path, "%try-load-path", 1, 2, 0,scm_sys_try_load_path);
+SCM
+scm_sys_try_load_path (filename, case_insensitive_p, sharp)
+ SCM filename;
+ SCM case_insensitive_p;
+ SCM sharp;
+{
+ SCM full_filename = scm_sys_search_load_path (filename);
+ if (SCM_FALSEP (full_filename))
+ {
+ scm_error (scm_misc_error_key,
+ s_sys_try_load_path,
+ "Unable to find file %S in %S",
+ scm_listify (filename, *scm_loc_load_path, SCM_UNDEFINED),
+ SCM_BOOL_F);
+ }
+ return scm_sys_try_load (full_filename, case_insensitive_p, sharp);
+}
+
+
+
void
scm_init_load ()
-#endif
{
+ scm_loc_load_path = &SCM_CDR(scm_sysintern("%load-path", SCM_EOL));
+
#include "load.x"
}
-
diff --git a/libguile/load.h b/libguile/load.h
index eab41b173..a1d37ab39 100644
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -43,20 +43,13 @@
* If you do not wish that, delete this exception notice.
*/
-
+#include "libguile/__scm.h"
-#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 */
-
-
-
+extern void scm_init_load_path SCM_P ((void));
+extern SCM scm_sys_try_load SCM_P ((SCM filename, SCM casep, SCM sharp));
+extern SCM scm_sys_search_load_path SCM_P ((SCM filename));
+extern SCM scm_sys_try_load_path SCM_P ((SCM filename, SCM casep, SCM sharp));
+extern void scm_init_load SCM_P ((void));
#endif /* LOADH */
diff --git a/libguile/mallocs.c b/libguile/mallocs.c
index 27f1a791c..fa4fd77c9 100644
--- a/libguile/mallocs.c
+++ b/libguile/mallocs.c
@@ -21,12 +21,16 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "smob.h"
+
#include "mallocs.h"
+
#ifdef HAVE_MALLOC_H
-#include "malloc.h"
+#include <malloc.h>
#endif
#ifdef HAVE_UNISTD_H
-#include "unistd.h"
+#include <unistd.h>
#endif
@@ -49,13 +53,13 @@ fmalloc(ptr)
#ifdef __STDC__
static int
-prinmalloc (SCM exp, SCM port, int writing)
+prinmalloc (SCM exp, SCM port, scm_print_state *pstate)
#else
static int
-prinmalloc (exp, port, writing)
+prinmalloc (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
scm_gen_puts(scm_regular_string, "#<malloc ", port);
diff --git a/libguile/mallocs.h b/libguile/mallocs.h
index 779c25d18..90a03c4b0 100644
--- a/libguile/mallocs.h
+++ b/libguile/mallocs.h
@@ -43,7 +43,9 @@
* If you do not wish that, delete this exception notice.
*/
+#include "libguile/__scm.h"
+
extern int scm_tc16_malloc;
#define SCM_MALLOCP(X) (SCM_TYP16 (X) == scm_tc16_malloc)
diff --git a/libguile/markers.c b/libguile/markers.c
index d6a3c8288..fa6705902 100644
--- a/libguile/markers.c
+++ b/libguile/markers.c
@@ -43,6 +43,7 @@
#include <stdio.h>
#include "_scm.h"
+#include "markers.h"
/* {GC marking}
diff --git a/libguile/markers.h b/libguile/markers.h
index 0debbc4ac..2a5e63a20 100644
--- a/libguile/markers.h
+++ b/libguile/markers.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/mbstrings.c b/libguile/mbstrings.c
index 4d8bb1834..e6a992c18 100644
--- a/libguile/mbstrings.c
+++ b/libguile/mbstrings.c
@@ -46,7 +46,12 @@
#include "extchrs.h"
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "unif.h"
+#include "genio.h"
+#include "read.h"
+#include "mbstrings.h"
SCM_PROC(s_multi_byte_string_p, "multi-byte-string?", 1, 0, 0, scm_multi_byte_string_p);
@@ -188,7 +193,7 @@ scm_symbol_multi_byte_p (symbol)
SCM symbol;
#endif
{
- return SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP(symbol);
+ return SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol);
}
SCM_PROC(s_set_symbol_multi_byte_x, "set-symbol-multi-byte!", 2, 0, 0, scm_set_symbol_multi_byte_x);
@@ -204,7 +209,7 @@ scm_set_symbol_multi_byte_x (symbol, val)
{
if (SCM_TYP7 (symbol) == scm_tc7_msymbol)
{
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP(symbol) = (SCM_FALSEP (val)
+ SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol) = (SCM_FALSEP (val)
? SCM_BOOL_F
: SCM_BOOL_T);
}
diff --git a/libguile/mbstrings.h b/libguile/mbstrings.h
index e1d3ef0cb..9c1414b97 100644
--- a/libguile/mbstrings.h
+++ b/libguile/mbstrings.h
@@ -44,13 +44,13 @@
*/
-#include "__scm.h"
-#include "symbols.h"
+#include "libguile/__scm.h"
+#include "libguile/symbols.h"
#define SCM_MB_STRINGP(x) ( (SCM_TYP7(x)==scm_tc7_mb_string) \
|| ( (SCM_TYP7(x) == scm_tc7_msymbol) \
- && (SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (x) != SCM_BOOL_F)))
+ && (SCM_SYMBOL_MULTI_BYTE_STRINGP (x) != SCM_BOOL_F)))
#define SCM_REGULAR_STRINGP(x) (SCM_TYP7D(x)==scm_tc7_string)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index b572ed79f..ddae40229 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -43,8 +43,10 @@
#include <stdio.h>
#include <math.h>
#include "_scm.h"
+#include "genio.h"
+#include "unif.h"
-
+#include "numbers.h"
#define DIGITS '0':case '1':case '2':case '3':case '4':\
case '5':case '6':case '7':case '8':case '9'
@@ -160,11 +162,11 @@ scm_abs(x)
#endif
if (SCM_INUM(x) >= 0) return x;
x = -SCM_INUM(x);
- if (!SCM_POSSCM_FIXABLE(x))
+ if (!SCM_POSFIXABLE(x))
#ifdef SCM_BIGDIG
return scm_long2big(x);
#else
- scm_wta(SCM_MAKINUM(-x), (char *)SCM_OVSCM_FLOW, s_abs);
+ scm_num_overflow (s_abs);
#endif
return SCM_MAKINUM(x);
}
@@ -227,7 +229,7 @@ scm_quotient(x, y)
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);
+ ov: scm_num_overflow (s_quotient);
z = SCM_INUM(x)/z;
#ifdef BADIVSGNS
{
@@ -247,7 +249,7 @@ scm_quotient(x, y)
#ifdef SCM_BIGDIG
return scm_long2big(z);
#else
- scm_wta(x, (char *)SCM_OVSCM_FLOW, s_quotient);
+ scm_num_overflow (s_quotient);
#endif
return SCM_MAKINUM(z);
}
@@ -287,7 +289,7 @@ scm_remainder(x, y)
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);
+ ov: scm_num_overflow (s_remainder);
#if (__TURBOC__==1)
if (z < 0) z = -z;
#endif
@@ -337,7 +339,7 @@ scm_modulo(x, y)
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);
+ ov: scm_num_overflow (s_modulo);
#if (__TURBOC__==1)
z = SCM_INUM(x);
z = ((yy<0) ? -z : z)%yy;
@@ -404,11 +406,11 @@ scm_gcd(x, y)
if ((t = u-v)) goto b3;
u = u*k;
getout:
- if (!SCM_POSSCM_FIXABLE(u))
+ if (!SCM_POSFIXABLE(u))
#ifdef SCM_BIGDIG
return scm_long2big(u);
#else
- scm_wta(x, (char *)SCM_OVSCM_FLOW, s_gcd);
+ scm_num_overflow (s_gcd);
#endif
return SCM_MAKINUM(u);
}
@@ -673,7 +675,8 @@ scm_ash(n, cnt)
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);
+ if (SCM_INUM(res)>>cnt != SCM_INUM(n))
+ scm_num_overflow (s_ash);
return res;
#endif
}
@@ -807,9 +810,9 @@ scm_big2inum(b, l)
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);
+ if SCM_POSFIXABLE(num) return SCM_MAKINUM(num);
}
- else if SCM_UNEGSCM_FIXABLE(num) return SCM_MAKINUM(-num);
+ else if SCM_UNEGFIXABLE(num) return SCM_MAKINUM(-num);
return b;
}
@@ -1189,7 +1192,7 @@ scm_divbigint(x, z, sgn, mode)
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;
+ if (mode && t2) t2 = z - t2;
return SCM_MAKINUM(sgn ? -t2 : t2);
}
{
@@ -1578,13 +1581,13 @@ scm_number_to_string(x, radix)
SCM_FLOATS or SCM_BIGDIGs conditionals */
#ifdef __STDC__
int
-scm_floprint(SCM sexp, SCM port, int writing)
+scm_floprint(SCM sexp, SCM port, scm_print_state *pstate)
#else
int
-scm_floprint(sexp, port, writing)
+scm_floprint(sexp, port, pstate)
SCM sexp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
#ifdef SCM_FLOATS
@@ -1599,13 +1602,13 @@ scm_floprint(sexp, port, writing)
#ifdef __STDC__
int
-scm_bigprint(SCM exp, SCM port, int writing)
+scm_bigprint(SCM exp, SCM port, scm_print_state *pstate)
#else
int
-scm_bigprint(exp, port, writing)
+scm_bigprint(exp, port, pstate)
SCM exp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
#ifdef SCM_BIGDIG
@@ -1619,7 +1622,51 @@ scm_bigprint(exp, port, writing)
/*** END nums->strs ***/
/*** STRINGS -> NUMBERS ***/
-#ifdef SCM_BIGDIG
+
+static SCM
+scm_small_istr2int(str, len, radix)
+ char *str;
+ long len;
+ long radix;
+{
+ register long n = 0, ln;
+ register int c;
+ register int i = 0;
+ int lead_neg = 0;
+ if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
+ switch (*str) { /* leading sign */
+ case '-': lead_neg = 1;
+ case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
+ }
+
+ do {
+ switch (c = str[i++]) {
+ case DIGITS:
+ c = c - '0';
+ goto accumulate;
+ case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ c = c-'A'+10;
+ goto accumulate;
+ case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
+ c = c-'a'+10;
+ accumulate:
+ if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
+ ln = n;
+ n = n * radix - c;
+ /* Negation is a workaround for HP700 cc bug */
+ if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM)) goto ovfl;
+ break;
+ default:
+ return SCM_BOOL_F; /* not a digit */
+ }
+ } while (i < len);
+ if (!lead_neg) if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM) goto ovfl;
+ return SCM_MAKINUM(n);
+ ovfl: /* overflow scheme integer */
+ return SCM_BOOL_F;
+}
+
+
#ifdef __STDC__
SCM
scm_istr2int(char *str, long len, long radix)
@@ -1640,6 +1687,12 @@ scm_istr2int(str, len, radix)
register unsigned long t2;
if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
+
+ /* Short numbers we parse directly into an int, to avoid the overhead
+ of creating a bignum. */
+ if (len < 6)
+ return scm_small_istr2int (str, len, radix);
+
if (16==radix) j = 1+(4*len*sizeof(char))/(SCM_BITSPERDIG);
else if (10 <= radix)
j = 1+(84*len*sizeof(char))/(SCM_BITSPERDIG*25);
@@ -1672,7 +1725,8 @@ scm_istr2int(str, len, radix)
ds[k++] = SCM_BIGLO(t2);
t2 = SCM_BIGDN(t2);
}
- SCM_ASSERT(blen <= j, (SCM)SCM_MAKINUM(blen), SCM_OVSCM_FLOW, "bignum");
+ if (blen > j)
+ scm_num_overflow ("bignum");
if (t2) {blen++; goto moretodo;}
break;
default:
@@ -1684,58 +1738,6 @@ scm_istr2int(str, len, radix)
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__
@@ -2806,7 +2808,7 @@ scm_sum(x, y)
# ifdef SCM_FLOATS
return scm_makdbl((double)x, 0.0);
# else
- scm_wta(y, (char *)SCM_OVSCM_FLOW, s_sum);
+ scm_num_overflow (s_sum);
return SCM_UNSPECIFIED;
# endif
#endif
@@ -2949,7 +2951,7 @@ scm_difference(x, y)
# ifdef SCM_FLOATS
return scm_makdbl((double)x, 0.0);
# else
- scm_wta(y, (char *)SCM_OVSCM_FLOW, s_difference);
+ scm_num_overflow (s_difference);
return SCM_UNSPECIFIED;
# endif
#endif
@@ -3103,7 +3105,7 @@ scm_product(x, y)
# ifdef SCM_FLOATS
return scm_makdbl(((double)i)*((double)j), 0.0);
# else
- scm_wta(y, (char *)SCM_OVSCM_FLOW, s_product);
+ scm_num_overflow (s_product);
# endif
#endif
return y;
@@ -3181,7 +3183,10 @@ scm_divide(x, y)
SCM z;
if SCM_INUMP(y) {
z = SCM_INUM(y);
- SCM_ASSERT(z, y, SCM_OVSCM_FLOW, s_divide);
+#ifndef RECKLESS
+ if (!z)
+ scm_num_overflow (s_divide);
+#endif
if (1==z) return x;
if (z < 0) z = -z;
if (z < SCM_BIGRAD) {
@@ -3321,7 +3326,7 @@ scm_divide(x, y)
#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);
+ ov: scm_num_overflow (s_divide);
return SCM_UNSPECIFIED;
#endif
}
@@ -3446,7 +3451,8 @@ SCM_PROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)())tanh);
struct dpair {double x, y;};
-void scm_two_doubles(z1, z2, sstring, xy)
+static void
+scm_two_doubles(z1, z2, sstring, xy)
SCM z1, z2;
char *sstring;
struct dpair *xy;
@@ -3488,7 +3494,7 @@ void scm_two_doubles(z1, z2, sstring, xy)
-SCM_PROC(s_sys_expt, "%expt", 2, 0, 0, scm_sys_expt);
+SCM_PROC(s_sys_expt, "$expt", 2, 0, 0, scm_sys_expt);
#ifdef __STDC__
SCM
scm_sys_expt(SCM z1, SCM z2)
@@ -3506,7 +3512,7 @@ scm_sys_expt(z1, z2)
-SCM_PROC(s_sys_atan2, "%atan2", 2, 0, 0, scm_sys_atan2);
+SCM_PROC(s_sys_atan2, "$atan2", 2, 0, 0, scm_sys_atan2);
#ifdef __STDC__
SCM
scm_sys_atan2(SCM z1, SCM z2)
@@ -3765,7 +3771,10 @@ scm_dbl2big(d)
u -= c;
digits[i] = c;
}
- SCM_ASSERT(0==u, SCM_INUM0, SCM_OVSCM_FLOW, "dbl2big");
+#ifndef RECKLESS
+ if (u != 0)
+ scm_num_overflow ("dbl2big");
+#endif
return ans;
}
@@ -3849,7 +3858,7 @@ scm_ulong2num(sl)
unsigned long sl;
#endif
{
- if (!SCM_POSSCM_FIXABLE(sl)) {
+ if (!SCM_POSFIXABLE(sl)) {
#ifdef SCM_BIGDIG
return scm_ulong2big(sl);
#else
@@ -3992,7 +4001,7 @@ scm_num2long_long(num, pos, s_caller)
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];
+ for(;l--;) res = SCM_LONGLONGBIGUP(res) + SCM_BDIGITS(num)[l];
return res;
}
#endif
diff --git a/libguile/numbers.h b/libguile/numbers.h
index abd1e7a24..c16d39a94 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -97,10 +97,10 @@
/* 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))
+#define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM)
+#define SCM_NEGFIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM)
+#define SCM_UNEGFIXABLE(n) ((n) <= -SCM_MOST_NEGATIVE_FIXNUM)
+#define SCM_FIXABLE(n) (SCM_POSFIXABLE(n) && SCM_NEGFIXABLE(n))
/* SCM_INTBUFLEN is the maximum number of characters neccessary for the
* printed or scm_string representation of an exact immediate.
@@ -167,7 +167,7 @@
# 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_LONGLONGBIGUP(x) ((ulong_long)(x) << SCM_BITSPERDIG)
# define SCM_BIGDN(x) ((x) >> SCM_BITSPERDIG)
# define SCM_BIGLO(x) ((x) & (SCM_BIGRAD-1))
#endif /* def BIGNUMS */
@@ -177,7 +177,7 @@
* prototypes to compile with conditionalization.
*/
# define SCM_BIGDIG unsigned short
-# define NO_SCM_BIGDIG
+# define SCM_NO_BIGDIG
# ifndef SCM_FLOATS
# define SCM_INUMS_ONLY
# endif /* ndef SCM_FLOATS */
@@ -240,11 +240,6 @@ 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);
@@ -270,9 +265,8 @@ 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 int scm_floprint(SCM sexp, SCM port, scm_print_state *pstate);
+extern int scm_bigprint(SCM exp, SCM port, scm_print_state *pstate);
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);
diff --git a/libguile/objprop.c b/libguile/objprop.c
index e97b591ce..1337c1221 100644
--- a/libguile/objprop.c
+++ b/libguile/objprop.c
@@ -42,7 +42,11 @@
#include <stdio.h>
#include "_scm.h"
+#include "hashtab.h"
+#include "alist.h"
+#include "weaks.h"
+#include "objprop.h"
/* {Object Properties}
@@ -58,7 +62,7 @@ scm_object_properties (obj)
SCM obj;
#endif
{
- return scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL);
+ return scm_hashq_ref (scm_object_whash, obj, SCM_EOL);
}
@@ -73,8 +77,7 @@ scm_set_object_properties_x (obj, plist)
SCM plist;
#endif
{
- SCM handle;
- scm_hashq_create_handle_x (scm_object_whash, obj, plist);
+ SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, plist);
SCM_SETCDR (handle, plist);
return plist;
}
@@ -131,7 +134,7 @@ void
scm_init_objprop ()
#endif
{
- scm_object_whash = scm_make_weak_hash_table (SCM_MAKINUM (511));
+ scm_object_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (511));
#include "objprop.x"
}
diff --git a/libguile/objprop.h b/libguile/objprop.h
index af3771c22..a1a19c241 100644
--- a/libguile/objprop.h
+++ b/libguile/objprop.h
@@ -45,7 +45,7 @@
#include <stdio.h>
-#include "_scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/options.c b/libguile/options.c
new file mode 100644
index 000000000..0960539ba
--- /dev/null
+++ b/libguile/options.c
@@ -0,0 +1,239 @@
+/* Copyright (C) 1995,1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include <stdio.h>
+#include "_scm.h"
+
+#include "options.h"
+
+
+/* {Run-time options}
+ *
+ * This is the basic interface for low-level configuration of the
+ * Guile library. It is used for configuring the reader, evaluator,
+ * printer and debugger.
+ *
+ * Motivation:
+ *
+ * 1. Altering option settings can have side effects.
+ * 2. Option values can be stored in native format.
+ * (Important for efficiency in, e. g., the evaluator.)
+ * 3. Doesn't use up name space.
+ * 4. Options can be naturally grouped => ease of use.
+ */
+
+/* scm_options is the core of all options interface procedures.
+ *
+ * Some definitions:
+ *
+ * Run time options in Guile are arranged in groups. Each group
+ * affects a certain aspect of the behaviour of the library.
+ *
+ * An "options interface procedure" manages one group of options. It
+ * can be used to check or set options, or to get documentation for
+ * all options of a group. The options interface procedure is not
+ * intended to be called directly by the user. The user should
+ * instead call
+ *
+ * (<group>-options)
+ * (<group>-options 'help)
+ * (<group>-options 'full)
+ *
+ * to display current option settings (The second version also
+ * displays documentation. The third version also displays
+ * information about programmer's options.), and
+ *
+ * (<group>-enable '<option-symbol>)
+ * (<group>-disable '<option-symbol>)
+ * (<group>-set! <option-symbol> <value>)
+ * (<group>-options <option setting>)
+ *
+ * to alter the state of an option (The last version sets all
+ * options according to <option setting>.) where <group> is the name
+ * of the option group.
+ *
+ * An "option setting" represents the state of all low-level options
+ * managed by one options interface procedure. It is a list of
+ * single symbols and symbols followed by a value.
+ *
+ * For boolean options, the presence of the symbol of that option in
+ * the option setting indicates a true value. If the symbol isn't a
+ * member of the option setting this represents a false value.
+ *
+ * Other options are represented by a symbol followed by the value.
+ *
+ * If scm_options is called without arguments, the current option
+ * setting is returned. If the argument is an option setting, options
+ * are altered and the old setting is returned. If the argument isn't
+ * a list, a list of sublists is returned, where each sublist contains
+ * option name, value and documentation string.
+ */
+
+SCM_SYMBOL (scm_yes_sym, "yes");
+SCM_SYMBOL (scm_no_sym, "no");
+
+#ifdef __STDC__
+SCM
+scm_options (SCM new_mode, scm_option options[], int n, char *s)
+#else
+SCM
+scm_options (new_mode, options, n, s)
+ SCM new_mode;
+ scm_option options[];
+ int n;
+ char *s;
+#endif
+{
+ int i, docp = (!SCM_UNBNDP (new_mode)
+ && (SCM_IMP (new_mode) || SCM_NCONSP (new_mode)));
+ SCM ans = SCM_EOL, ls;
+ for (i = 0; i < n; ++i)
+ {
+ ls = docp ? scm_cons ((SCM) options[i].doc, SCM_EOL) : ans;
+ switch (options[i].type)
+ {
+ case SCM_OPTION_BOOLEAN:
+ if (docp)
+ ls = scm_cons ((int) options[i].val
+ ? scm_yes_sym
+ : scm_no_sym,
+ ls);
+ break;
+ case SCM_OPTION_INTEGER:
+ ls = scm_cons (SCM_MAKINUM ((int) options[i].val), ls);
+ break;
+ case SCM_OPTION_SCM:
+ ls = scm_cons ((SCM) options[i].val, ls);
+ }
+ if (!((options[i].type == SCM_OPTION_BOOLEAN)
+ && !docp
+ && ! (int) options[i].val))
+ ls = scm_cons ((SCM) options[i].name, ls);
+ ans = docp ? scm_cons (ls, ans) : ls;
+ }
+ if (!(SCM_UNBNDP (new_mode) || docp))
+ {
+ unsigned long *flags;
+ flags = (unsigned long *) scm_must_malloc (n * sizeof (unsigned long),
+ "mode buffer");
+ for (i = 0; i < n; ++i)
+ if (options[i].type == SCM_OPTION_BOOLEAN)
+ flags[i] = 0;
+ else
+ flags[i] = (unsigned long) options[i].val;
+ while (SCM_NNULLP (new_mode))
+ {
+ SCM_ASSERT (SCM_NIMP (new_mode) && SCM_CONSP (new_mode),
+ new_mode,
+ SCM_ARG1,
+ s);
+ for (i = 0; i < n; ++i)
+ if (SCM_CAR (new_mode) == (SCM) options[i].name)
+ switch (options[i].type)
+ {
+ case SCM_OPTION_BOOLEAN:
+ flags[i] = 1;
+ goto cont;
+ case SCM_OPTION_INTEGER:
+ new_mode = SCM_CDR (new_mode);
+ SCM_ASSERT (SCM_NIMP (new_mode)
+ && SCM_CONSP (new_mode)
+ && SCM_INUMP (SCM_CAR (new_mode)),
+ new_mode,
+ SCM_ARG1,
+ s);
+ flags[i] = (unsigned long) SCM_INUM (SCM_CAR (new_mode));
+ goto cont;
+ case SCM_OPTION_SCM:
+ new_mode = SCM_CDR (new_mode);
+ flags[i] = SCM_CAR (new_mode);
+ goto cont;
+ }
+#ifndef RECKLESS
+ scm_must_free ((char *) flags);
+ scm_wta (SCM_CAR (new_mode), "Unknown mode flag", s);
+#endif
+ cont:
+ new_mode = SCM_CDR (new_mode);
+ }
+ for (i = 0; i < n; ++i) options[i].val = flags[i];
+ scm_must_free ((char *) flags);
+ }
+ return ans;
+}
+
+#ifdef __STDC__
+void
+scm_init_opts (SCM (*func) (SCM), scm_option options[], int n)
+#else
+void
+scm_init_opts (func, options, n)
+ SCM (*func) (SCM);
+ scm_option options[];
+ int n;
+#endif
+{
+ int i;
+
+ for (i = 0; i < n; ++i)
+ {
+ options[i].name = (char *) SCM_CAR (scm_sysintern (options[i].name,
+ SCM_UNDEFINED));
+ options[i].doc = (char *) scm_permanent_object (scm_take0str
+ (options[i].doc));
+ }
+ func (SCM_UNDEFINED);
+}
+
+#ifdef __STDC__
+void
+scm_init_options (void)
+#else
+void
+scm_init_options ()
+#endif
+{
+#include "options.x"
+}
diff --git a/libguile/options.h b/libguile/options.h
new file mode 100644
index 000000000..d0462af61
--- /dev/null
+++ b/libguile/options.h
@@ -0,0 +1,78 @@
+/* classes: h_files */
+
+#ifndef OPTIONSH
+#define OPTIONSH
+/* Copyright (C) 1995,1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include "libguile/__scm.h"
+
+
+
+typedef struct scm_option
+{
+ int type;
+ char *name;
+ unsigned long val;
+ char *doc;
+} scm_option;
+
+#define SCM_OPTION_BOOLEAN 0
+#define SCM_OPTION_INTEGER 1
+#define SCM_OPTION_SCM 2
+
+extern SCM scm_yes_sym, scm_no_sym;
+
+#ifdef __STDC__
+extern SCM scm_options (SCM new_mode, scm_option options[], int n, char *s);
+extern void scm_init_opts (SCM (*func) (SCM), scm_option options[], int n);
+extern void scm_init_options (void);
+#else /* STDC */
+extern SCM scm_options ();
+extern void scm_init_opts ();
+extern void scm_init_options ();
+#endif /* STDC */
+
+#endif /* OPTIONSH */
diff --git a/libguile/pairs.h b/libguile/pairs.h
index b27e9c908..fd0771115 100644
--- a/libguile/pairs.h
+++ b/libguile/pairs.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -89,7 +89,6 @@ typedef SCM huge *SCMPTR;
#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))
diff --git a/libguile/ports.c b/libguile/ports.c
index cbaecbc03..12381ddf4 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -41,16 +41,27 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "chars.h"
+#include "markers.h"
+#include "fports.h"
+#include "strports.h"
+#include "vports.h"
+
+#include "ports.h"
#ifdef HAVE_MALLOC_H
-#include "malloc.h"
+#include <malloc.h>
#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
+#ifdef HAVE_SYS_IOCTL_H
+#include <sys/ioctl.h>
+#endif
@@ -438,9 +449,8 @@ scm_pt_member (member)
#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.
+/* Find a port in the table and return its revealed count.
+ Also used by the garbage collector.
*/
#ifdef __STDC__
int
@@ -468,14 +478,8 @@ 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);
+ return SCM_MAKINUM (scm_revealed_count (port));
}
/* Set the revealed count for a port. */
@@ -495,7 +499,7 @@ scm_set_port_revealed_x (port, rcount)
SCM_DEFER_INTS;
SCM_REVEALED (port) = SCM_INUM (rcount);
SCM_ALLOW_INTS;
- return SCM_BOOL_F;
+ return SCM_UNSPECIFIED;
}
/* scm_close_port
@@ -702,13 +706,13 @@ scm_unread_char (cobj, port)
-SCM_PROC (s_line_number, "line-number", 0, 1, 0, scm_line_number);
+SCM_PROC (s_port_line, "port-line", 0, 1, 0, scm_port_line);
#ifdef __STDC__
SCM
-scm_line_number (SCM port)
+scm_port_line (SCM port)
#else
SCM
-scm_line_number (port)
+scm_port_line (port)
SCM port;
#endif
{
@@ -722,13 +726,13 @@ scm_line_number (port)
return SCM_MAKINUM (SCM_LINUM (p));
}
-SCM_PROC (s_column_number, "column-number", 0, 1, 0, scm_column_number);
+SCM_PROC (s_port_column, "port-column", 0, 1, 0, scm_port_column);
#ifdef __STDC__
SCM
-scm_column_number (SCM port)
+scm_port_column (SCM port)
#else
SCM
-scm_column_number (port)
+scm_port_column (port)
SCM port;
#endif
{
@@ -742,14 +746,13 @@ scm_column_number (port)
return SCM_MAKINUM (SCM_COL (p));
}
-/* !!! dubious feature */
-SCM_PROC (s_port_file_name, "port-file-name", 0, 1, 0, scm_port_file_name);
+SCM_PROC (s_port_filename, "port-filename", 0, 1, 0, scm_port_filename);
#ifdef __STDC__
SCM
-scm_port_file_name (SCM port)
+scm_port_filename (SCM port)
#else
SCM
-scm_port_file_name (port)
+scm_port_filename (port)
SCM port;
#endif
{
@@ -763,6 +766,30 @@ scm_port_file_name (port)
return SCM_PTAB_ENTRY (p)->file_name;
}
+SCM_PROC (s_set_port_filename_x, "set-port-filename!", 1, 1, 0, scm_set_port_filename_x);
+#ifdef __STDC__
+SCM
+scm_set_port_filename_x (SCM port, SCM filename)
+#else
+SCM
+scm_set_port_filename_x (port, filename)
+ SCM port;
+ SCM filename;
+#endif
+{
+ if (filename == SCM_UNDEFINED)
+ {
+ filename = port;
+ port = scm_cur_inp;
+ }
+ else
+ SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
+ port,
+ SCM_ARG1,
+ s_set_port_filename_x);
+ return SCM_PTAB_ENTRY (port)->file_name = filename;
+}
+
#ifndef ttyname
extern char * ttyname();
#endif
diff --git a/libguile/ports.h b/libguile/ports.h
index fac20af77..4cbba8ea1 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -44,8 +44,7 @@
*/
-#include "__scm.h"
-#include "smob.h"
+#include "libguile/__scm.h"
@@ -72,23 +71,23 @@ struct scm_port_table
*/
SCM stream;
- SCM file_name;
+ SCM file_name; /* debugging support. */
int unchr; /* pushed back character, if any */
- int line_number;
- int column_number;
+ int line_number; /* debugging support. */
+ int column_number; /* debugging support. */
enum scm_port_representation_type representation;
};
extern struct scm_port_table **scm_port_table;
-extern scm_port_table_size; /* Number of ports in scm_port_table. */
+extern int scm_port_table_size; /* Number of ports in scm_port_table. */
/* PORT FLAGS
- * A set of flags caracterizes a port.
+ * A set of flags characterizes a port.
*/
#define SCM_OPN (1L<<16) /* Is the port open? */
#define SCM_RDNG (2L<<16) /* Is it a readable port? */
@@ -116,6 +115,7 @@ extern scm_port_table_size; /* Number of ports in scm_port_table. */
#define SCM_SETPTAB_ENTRY(x,ent) SCM_SETCDR ((x), (SCM)(ent))
#define SCM_STREAM(x) SCM_PTAB_ENTRY(x)->stream
#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = s)
+#define SCM_FILENAME(x) SCM_PTAB_ENTRY(x)->file_name
#define SCM_LINUM(x) SCM_PTAB_ENTRY(x)->line_number
#define SCM_COL(x) SCM_PTAB_ENTRY(x)->column_number
#define SCM_REVEALED(x) SCM_PTAB_ENTRY(x)->revealed
@@ -130,12 +130,30 @@ extern scm_port_table_size; /* Number of ports in scm_port_table. */
#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;}
+#define SCM_TABCOL(port) {SCM_COL (port) += 8 - SCM_COL (port) % 8;}
+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_PTOBNUM(x) (0x0ff & (SCM_CAR(x)>>8));
+
+
+
extern scm_ptobfuns *scm_ptobs;
extern scm_sizet scm_numptob;
extern int scm_port_table_room;
@@ -161,6 +179,7 @@ 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_close_all_ports_except (SCM ports);
extern SCM scm_input_port_p (SCM x);
extern SCM scm_output_port_p (SCM x);
extern SCM scm_eof_object_p (SCM x);
@@ -168,9 +187,10 @@ 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 SCM scm_port_line (SCM port);
+extern SCM scm_port_column (SCM port);
+extern SCM scm_port_filename (SCM port);
+extern SCM scm_set_port_filename_x (SCM port, SCM filename);
extern void scm_prinport (SCM exp, SCM port, char *type);
extern void scm_ports_prehistory (void);
extern SCM scm_void_port (char * mode_str);
@@ -197,6 +217,7 @@ 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_close_all_ports_except ();
extern SCM scm_input_port_p ();
extern SCM scm_output_port_p ();
extern SCM scm_eof_object_p ();
@@ -204,9 +225,10 @@ 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 SCM scm_port_line ();
+extern SCM scm_port_column ();
+extern SCM scm_port_filename ();
+extern SCM scm_set_port_filename_x ();
extern void scm_prinport ();
extern void scm_ports_prehistory ();
extern SCM scm_void_port ();
diff --git a/libguile/posix.c b/libguile/posix.c
index 11136be1d..5d70baf34 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -42,9 +42,20 @@
#include <stdio.h>
#include "_scm.h"
-
+#include "fports.h"
+#include "genio.h"
+#include "scmsigs.h"
+#include "read.h"
+#include "unif.h"
+#include "feature.h"
+#include "sequences.h"
+
+#include "posix.h"
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
#ifdef TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
@@ -58,12 +69,21 @@
#ifdef HAVE_UNISTD_H
#include <unistd.h>
+#else
+#ifndef ttyname
+extern char *ttyname();
+#endif
+#endif
+
+#ifdef HAVE_LIBC_H
+#include <libc.h>
#endif
#ifdef HAVE_SYS_SELECT_H
#include <sys/select.h>
#endif
+#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
@@ -98,7 +118,6 @@
#endif /* no FD_SET */
-extern char *ttyname ();
extern FILE *popen ();
extern char ** environ;
@@ -128,11 +147,47 @@ char *strptime ();
#include <locale.h>
#endif
+/* Some Unix systems don't define these. CPP hair is dangerous, but
+ this seems safe enough... */
+#ifndef R_OK
+#define R_OK 4
+#endif
+
+#ifndef W_OK
+#define W_OK 2
+#endif
+
+#ifndef X_OK
+#define X_OK 1
+#endif
+
+#ifndef F_OK
+#define F_OK 0
+#endif
+
+/* On NextStep, <utime.h> doesn't define struct utime, unless we
+ #define _POSIX_SOURCE before #including it. I think this is less
+ of a kludge than defining struct utimbuf ourselves. */
+#ifdef UTIMBUF_NEEDS_POSIX
+#define _POSIX_SOURCE
+#endif
+
+#ifdef HAVE_SYS_UTIME_H
+#include <sys/utime.h>
+#endif
+
+#ifdef HAVE_UTIME_H
+#include <utime.h>
+#endif
+
+/* Please don't add any more #includes or #defines here. The hack
+ above means that _POSIX_SOURCE may be #defined, which will
+ encourage header files to do strange things. */
-SCM_PROC (s_sys_pipe, "%pipe", 0, 0, 0, scm_sys_pipe);
+SCM_PROC (s_sys_pipe, "pipe", 0, 0, 0, scm_sys_pipe);
#ifdef __STDC__
SCM
scm_sys_pipe (void)
@@ -144,21 +199,20 @@ scm_sys_pipe ()
int fd[2], rv;
FILE *f_rd, *f_wt;
SCM p_rd, p_wt;
+ struct scm_port_table * ptr;
+ struct scm_port_table * ptw;
+
SCM_NEWCELL (p_rd);
SCM_NEWCELL (p_wt);
rv = pipe (fd);
if (rv)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
+ scm_syserror (s_sys_pipe);
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;
+ scm_syserror (s_sys_pipe);
}
f_wt = fdopen (fd[1], "w");
if (!f_wt)
@@ -167,29 +221,25 @@ scm_sys_pipe ()
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);
+ errno = en;
+ scm_syserror (s_sys_pipe);
}
+ ptr = scm_add_to_port_table (p_rd);
+ ptw = scm_add_to_port_table (p_wt);
+ SCM_SETPTAB_ENTRY (p_rd, ptr);
+ SCM_SETPTAB_ENTRY (p_wt, ptw);
+ SCM_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);
+SCM_PROC (s_sys_getgroups, "getgroups", 0, 0, 0, scm_sys_getgroups);
#ifdef __STDC__
SCM
scm_sys_getgroups(void)
@@ -200,21 +250,21 @@ scm_sys_getgroups()
{
SCM grps, ans;
int ngroups = getgroups (0, NULL);
- if (!ngroups) return SCM_BOOL_F;
+ if (!ngroups)
+ scm_syserror (s_sys_getgroups);
SCM_NEWCELL(grps);
SCM_DEFER_INTS;
{
GETGROUPS_T *groups;
int val;
- groups = (gid_t *)scm_must_malloc(ngroups * sizeof(GETGROUPS_T),
- s_sys_getgroups);
+ groups = (GETGROUPS_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_syserror (s_sys_getgroups);
}
SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */
SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string);
@@ -228,7 +278,7 @@ scm_sys_getgroups()
-SCM_PROC (s_sys_getpwuid, "%getpw", 0, 1, 0, scm_sys_getpwuid);
+SCM_PROC (s_sys_getpwuid, "getpw", 0, 1, 0, scm_sys_getpwuid);
#ifdef __STDC__
SCM
scm_sys_getpwuid (SCM user)
@@ -263,10 +313,8 @@ scm_sys_getpwuid (user)
entry = getpwnam (SCM_ROCHARS (user));
}
if (!entry)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
+ scm_syserror (s_sys_getpwuid);
+
ve[0] = scm_makfrom0str (entry->pw_name);
ve[1] = scm_makfrom0str (entry->pw_passwd);
ve[2] = scm_ulong2num ((unsigned long) entry->pw_uid);
@@ -306,7 +354,7 @@ scm_setpwent (arg)
/* Combines getgrgid and getgrnam. */
-SCM_PROC (s_sys_getgrgid, "%getgr", 0, 1, 0, scm_sys_getgrgid);
+SCM_PROC (s_sys_getgrgid, "getgr", 0, 1, 0, scm_sys_getgrgid);
#ifdef __STDC__
SCM
scm_sys_getgrgid (SCM name)
@@ -334,10 +382,8 @@ scm_sys_getgrgid (name)
SCM_SYSCALL (entry = getgrnam (SCM_CHARS (name)));
}
if (!entry)
- {
- SCM_ALLOW_INTS;
- return SCM_MAKINUM (errno);
- }
+ scm_syserror (s_sys_getgrgid);
+
ve[0] = scm_makfrom0str (entry->gr_name);
ve[1] = scm_makfrom0str (entry->gr_passwd);
ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid);
@@ -367,7 +413,7 @@ scm_setgrent (arg)
-SCM_PROC (s_sys_kill, "%kill", 2, 0, 0, scm_sys_kill);
+SCM_PROC (s_sys_kill, "kill", 2, 0, 0, scm_sys_kill);
#ifdef __STDC__
SCM
scm_sys_kill (SCM pid, SCM sig)
@@ -378,17 +424,17 @@ scm_sys_kill (pid, sig)
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;
+ if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0)
+ scm_syserror (s_sys_kill);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_waitpid, "%waitpid", 1, 1, 0, scm_sys_waitpid);
+SCM_PROC (s_sys_waitpid, "waitpid", 1, 1, 0, scm_sys_waitpid);
#ifdef __STDC__
SCM
scm_sys_waitpid (SCM pid, SCM options)
@@ -399,6 +445,7 @@ scm_sys_waitpid (pid, options)
SCM options;
#endif
{
+#ifdef HAVE_WAITPID
int i;
int status;
int ioptions;
@@ -412,9 +459,14 @@ scm_sys_waitpid (pid, options)
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)));
+ if (i == -1)
+ scm_syserror (s_sys_waitpid);
+ return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status));
+#else
+ scm_sysmissing (s_sys_waitpid);
+ /* not reached. */
+ return SCM_BOOL_F;
+#endif
}
@@ -496,7 +548,7 @@ scm_getegid ()
}
-SCM_PROC (s_sys_setuid, "%setuid", 1, 0, 0, scm_sys_setuid);
+SCM_PROC (s_sys_setuid, "setuid", 1, 0, 0, scm_sys_setuid);
#ifdef __STDC__
SCM
scm_sys_setuid (SCM id)
@@ -507,10 +559,12 @@ scm_sys_setuid (id)
#endif
{
SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setuid);
- return setuid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (setuid (SCM_INUM (id)) != 0)
+ scm_syserror (s_sys_setuid);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_setgid, "%setgid", 1, 0, 0, scm_sys_setgid);
+SCM_PROC (s_sys_setgid, "setgid", 1, 0, 0, scm_sys_setgid);
#ifdef __STDC__
SCM
scm_sys_setgid (SCM id)
@@ -521,10 +575,12 @@ scm_sys_setgid (id)
#endif
{
SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_sys_setgid);
- return setgid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ if (setgid (SCM_INUM (id)) != 0)
+ scm_syserror (s_sys_setgid);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_seteuid, "%seteuid", 1, 0, 0, scm_sys_seteuid);
+SCM_PROC (s_sys_seteuid, "seteuid", 1, 0, 0, scm_sys_seteuid);
#ifdef __STDC__
SCM
scm_sys_seteuid (SCM id)
@@ -534,15 +590,20 @@ scm_sys_seteuid (id)
SCM id;
#endif
{
+ int rv;
+
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;
+ rv = seteuid (SCM_INUM (id));
#else
- return setuid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ rv = setuid (SCM_INUM (id));
#endif
+ if (rv != 0)
+ scm_syserror (s_sys_seteuid);
+ return SCM_UNSPECIFIED;
}
-SCM_PROC (s_sys_setegid, "%setegid", 1, 0, 0, scm_sys_setegid);
+SCM_PROC (s_sys_setegid, "setegid", 1, 0, 0, scm_sys_setegid);
#ifdef __STDC__
SCM
scm_sys_setegid (SCM id)
@@ -552,12 +613,18 @@ scm_sys_setegid (id)
SCM id;
#endif
{
+ int rv;
+
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;
+ rv = setegid (SCM_INUM (id));
#else
- return setgid (SCM_INUM (id)) ? SCM_MAKINUM (errno) : SCM_BOOL_T;
+ rv = setgid (SCM_INUM (id));
#endif
+ if (rv != 0)
+ scm_syserror (s_sys_setegid);
+ return SCM_UNSPECIFIED;
+
}
SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp);
@@ -565,34 +632,46 @@ SCM
scm_getpgrp ()
{
int (*fn)();
- fn = getpgrp;
+ fn = (int (*) ()) getpgrp;
return SCM_MAKINUM (fn (0));
}
-SCM_PROC (s_setpgid, "%setpgid", 2, 0, 0, scm_setpgid);
+SCM_PROC (s_sys_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;
+#ifdef HAVE_SETPGID
+ SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_sys_setpgid);
+ SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_sys_setpgid);
+ /* FIXME(?): may be known as setpgrp. */
+ if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0)
+ scm_syserror (s_sys_setpgid);
+ return SCM_UNSPECIFIED;
+#else
+ scm_sysmissing (s_sys_setpgid);
+ /* not reached. */
+ return SCM_BOOL_F;
+#endif
}
-SCM_PROC (s_setsid, "%setsid", 0, 0, 0, scm_setsid);
+SCM_PROC (s_sys_setsid, "setsid", 0, 0, 0, scm_setsid);
SCM
scm_setsid ()
{
+#ifdef HAVE_SETSID
pid_t sid = setsid ();
- return (sid == -1) ? SCM_BOOL_F : SCM_MAKINUM (sid);
-}
-
-#ifndef ttyname
-extern char * ttyname();
+ if (sid == -1)
+ scm_syserror (s_sys_setsid);
+ return SCM_UNSPECIFIED;
+#else
+ scm_sysmissing (s_sys_setsid);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
+}
-SCM_PROC (s_ttyname, "%ttyname", 1, 0, 0, scm_ttyname);
+SCM_PROC (s_ttyname, "ttyname", 1, 0, 0, scm_ttyname);
#ifdef __STDC__
SCM
scm_ttyname (SCM port)
@@ -608,51 +687,70 @@ scm_ttyname (port)
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));
+ if (fd == -1)
+ scm_syserror (s_ttyname);
+ SCM_SYSCALL (ans = ttyname (fd));
+ if (!ans)
+ scm_syserror (s_ttyname);
/* ans could be overwritten by another call to ttyname */
- return (((fd != -1) && ans)
- ? scm_makfrom0str (ans)
- : SCM_MAKINUM (errno));
+ return (scm_makfrom0str (ans));
}
-SCM_PROC (s_ctermid, "%ctermid", 0, 0, 0, scm_ctermid);
+SCM_PROC (s_sys_ctermid, "ctermid", 0, 0, 0, scm_ctermid);
SCM
scm_ctermid ()
{
+#ifdef HAVE_CTERMID
char *result = ctermid (NULL);
- return *result == '\0' ? SCM_BOOL_F : scm_makfrom0str (result);
+ if (*result == '\0')
+ scm_syserror (s_sys_ctermid);
+ return scm_makfrom0str (result);
+#else
+ scm_sysmissing (s_sys_ctermid);
+ /* not reached. */
+ return SCM_BOOL_F;
+#endif
}
-SCM_PROC (s_tcgetpgrp, "%tcgetpgrp", 1, 0, 0, scm_tcgetpgrp);
+SCM_PROC (s_sys_tcgetpgrp, "tcgetpgrp", 1, 0, 0, scm_tcgetpgrp);
SCM
scm_tcgetpgrp (port)
SCM port;
{
+#ifdef HAVE_TCGETPGRP
int fd;
pid_t pgid;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp);
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_tcgetpgrp);
fd = fileno ((FILE *)SCM_STREAM (port));
if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1)
- return SCM_BOOL_F;
- else
- return SCM_MAKINUM (pgid);
+ scm_syserror (s_sys_tcgetpgrp);
+ return SCM_MAKINUM (pgid);
+#else
+ scm_sysmissing (s_sys_tcgetpgrp);
+ /* not reached. */
+ return SCM_BOOL_F;
+#endif
}
-SCM_PROC (s_tcsetpgrp, "%tcsetpgrp", 2, 0, 0, scm_tcsetpgrp);
+SCM_PROC (s_sys_tcsetpgrp, "tcsetpgrp", 2, 0, 0, scm_tcsetpgrp);
SCM
scm_tcsetpgrp (port, pgid)
SCM port, pgid;
{
+#ifdef HAVE_TCSETPGRP
int fd;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcsetpgrp);
- SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp);
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_tcsetpgrp);
+ SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_sys_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;
+ scm_syserror (s_sys_tcsetpgrp);
+ return SCM_UNSPECIFIED;
+#else
+ scm_sysmissing (s_sys_tcsetpgrp);
+ /* not reached. */
+ return SCM_BOOL_F;
+#endif
}
/* Copy exec args from an SCM vector into a new C array. */
@@ -691,7 +789,7 @@ scm_convert_exec_args (args)
return execargv;
}
-SCM_PROC (s_sys_execl, "%execl", 0, 0, 1, scm_sys_execl);
+SCM_PROC (s_sys_execl, "execl", 0, 0, 1, scm_sys_execl);
#ifdef __STDC__
SCM
scm_sys_execl (SCM args)
@@ -709,10 +807,12 @@ scm_sys_execl (args)
args = SCM_CDR (args);
execargv = scm_convert_exec_args (args);
execv (SCM_ROCHARS (filename), execargv);
- return SCM_MAKINUM (errno);
+ scm_syserror (s_sys_execl);
+ /* not reached. */
+ return SCM_BOOL_F;
}
-SCM_PROC (s_sys_execlp, "%execlp", 0, 0, 1, scm_sys_execlp);
+SCM_PROC (s_sys_execlp, "execlp", 0, 0, 1, scm_sys_execlp);
#ifdef __STDC__
SCM
scm_sys_execlp (SCM args)
@@ -730,11 +830,13 @@ scm_sys_execlp (args)
args = SCM_CDR (args);
execargv = scm_convert_exec_args (args);
execvp (SCM_ROCHARS (filename), execargv);
- return SCM_MAKINUM (errno);
+ scm_syserror (s_sys_execlp);
+ /* not reached. */
+ return SCM_BOOL_F;
}
/* Flushing streams etc., is not done here. */
-SCM_PROC (s_sys_fork, "%fork", 0, 0, 0, scm_sys_fork);
+SCM_PROC (s_sys_fork, "fork", 0, 0, 0, scm_sys_fork);
#ifdef __STDC__
SCM
scm_sys_fork(void)
@@ -743,16 +845,15 @@ SCM
scm_sys_fork()
#endif
{
- pid_t pid;
+ int pid;
pid = fork ();
if (pid == -1)
- return SCM_BOOL_F;
- else
- return SCM_MAKINUM (0L+pid);
+ scm_syserror (s_sys_fork);
+ return SCM_MAKINUM (0L+pid);
}
-SCM_PROC (s_sys_uname, "%uname", 0, 0, 0, scm_sys_uname);
+SCM_PROC (s_sys_uname, "uname", 0, 0, 0, scm_sys_uname);
#ifdef __STDC__
SCM
scm_sys_uname (void)
@@ -773,12 +874,14 @@ scm_sys_uname ()
ve[3] = scm_makfrom0str (buf.version);
ve[4] = scm_makfrom0str (buf.machine);
/*
- FIXME
+ a linux special?
ve[5] = scm_makfrom0str (buf.domainname);
*/
return ans;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_sys_uname);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
@@ -853,6 +956,8 @@ scm_open_pipe (pipestr, modes)
{
FILE *f;
register SCM z;
+ struct scm_port_table * pt;
+
SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr, SCM_ARG1, s_open_pipe);
if (SCM_SUBSTRP (pipestr))
pipestr = scm_makfromstr (SCM_ROCHARS (pipestr), SCM_ROLENGTH (pipestr), 0);
@@ -865,15 +970,12 @@ scm_open_pipe (pipestr, modes)
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_syserror (s_open_pipe);
+ 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;
}
@@ -906,13 +1008,7 @@ scm_open_output_pipe(pipestr)
}
-#ifdef __EMX__
-#include <sys/utime.h>
-#else
-#include <utime.h>
-#endif
-
-SCM_PROC (s_sys_utime, "%utime", 1, 2, 0, scm_sys_utime);
+SCM_PROC (s_sys_utime, "utime", 1, 2, 0, scm_sys_utime);
#ifdef __STDC__
SCM
scm_sys_utime (SCM pathname, SCM actime, SCM modtime)
@@ -940,13 +1036,11 @@ scm_sys_utime (pathname, actime, modtime)
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;
+ if (rv != 0)
+ scm_syserror (s_sys_utime);
+ return SCM_UNSPECIFIED;
}
-
-
-
-
SCM_PROC (s_sys_access, "access?", 2, 0, 0, scm_sys_access);
#ifdef __STDC__
SCM
@@ -968,8 +1062,6 @@ scm_sys_access (path, how)
return rv ? SCM_BOOL_F : SCM_BOOL_T;
}
-
-
SCM_PROC (s_getpid, "getpid", 0, 0, 0, scm_getpid);
#ifdef __STDC__
SCM
@@ -982,8 +1074,7 @@ scm_getpid ()
return SCM_MAKINUM ((unsigned long) getpid ());
}
-
-SCM_PROC (s_sys_putenv, "%putenv", 1, 0, 0, scm_sys_putenv);
+SCM_PROC (s_sys_putenv, "putenv", 1, 0, 0, scm_sys_putenv);
#ifdef __STDC__
SCM
scm_sys_putenv (SCM str)
@@ -997,11 +1088,12 @@ scm_sys_putenv (str)
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);
+ scm_sysmissing (s_sys_putenv);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
-
SCM_PROC (s_read_line, "read-line", 0, 2, 0, scm_read_line);
#ifdef __STDC__
SCM
@@ -1064,8 +1156,6 @@ scm_read_line (port, include_terminator)
}
}
-
-
SCM_PROC (s_read_line_x, "read-line!", 1, 1, 0, scm_read_line_x);
#ifdef __STDC__
SCM
@@ -1110,8 +1200,6 @@ scm_read_line_x (str, port)
}
}
-
-
SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line);
#ifdef __STDC__
SCM
@@ -1127,9 +1215,7 @@ scm_write_line (obj, port)
return scm_newline (port);
}
-
-
-SCM_PROC (s_setlocale, "%setlocale", 1, 1, 0, scm_setlocale);
+SCM_PROC (s_setlocale, "setlocale", 1, 1, 0, scm_setlocale);
#ifdef __STDC__
SCM
scm_setlocale (SCM category, SCM locale)
@@ -1156,10 +1242,13 @@ scm_setlocale (category, locale)
}
rv = setlocale (SCM_INUM (category), clocale);
- return rv ? scm_makfrom0str (rv) : SCM_MAKINUM (errno);
+ if (rv == NULL)
+ scm_syserror (s_setlocale);
+ return scm_makfrom0str (rv);
#else
- /* setlocale not available. */
- return SCM_MAKINUM (errno);
+ scm_sysmissing (s_setlocale);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
@@ -1216,9 +1305,7 @@ scm_strftime (format, stime)
return scm_makfromstr (tbuf, len, 0);
}
-
-
-SCM_PROC (s_sys_strptime, "%strptime", 2, 0, 0, scm_sys_strptime);
+SCM_PROC (s_sys_strptime, "strptime", 2, 0, 0, scm_sys_strptime);
#ifdef __STDC__
SCM
scm_sys_strptime (SCM format, SCM string)
@@ -1234,7 +1321,6 @@ scm_sys_strptime (format, string)
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);
@@ -1264,9 +1350,8 @@ scm_sys_strptime (format, string)
rest = strptime (str, fmt, &t);
SCM_ALLOW_INTS;
- if (rest == NULL) {
- return SCM_BOOL_F;
- }
+ if (rest == NULL)
+ scm_syserror (s_sys_strptime);
stime = scm_make_vector (SCM_MAKINUM (9), scm_long2num (0), SCM_UNDEFINED);
@@ -1285,12 +1370,13 @@ scm_sys_strptime (format, string)
return scm_cons (stime, scm_makfrom0str (rest));
#else
- scm_wta (SCM_UNSPECIFIED, "strptime is not available and no replacement has (yet) been supplied", "strptime");
+ scm_sysmissing (s_sys_strptime);
+ /* not reached. */
return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_mknod, "%mknod", 3, 0, 0, scm_sys_mknod);
+SCM_PROC (s_sys_mknod, "mknod", 3, 0, 0, scm_sys_mknod);
#ifdef __STDC__
SCM
scm_sys_mknod(SCM path, SCM mode, SCM dev)
@@ -1308,14 +1394,18 @@ scm_sys_mknod(path, mode, dev)
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;
+ if (val != 0)
+ scm_syserror (s_sys_mknod);
+ return SCM_UNSPECIFIED;
#else
+ scm_sysmissing (s_sys_mknod);
+ /* not reached. */
return SCM_BOOL_F;
#endif
}
-SCM_PROC (s_sys_nice, "%nice", 1, 0, 0, scm_sys_nice);
+SCM_PROC (s_sys_nice, "nice", 1, 0, 0, scm_sys_nice);
#ifdef __STDC__
SCM
scm_sys_nice(SCM incr)
@@ -1327,9 +1417,13 @@ scm_sys_nice(incr)
{
#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;
+ if (nice(SCM_INUM(incr)) != 0)
+ scm_syserror (s_sys_nice);
+ return SCM_UNSPECIFIED;
#else
- return SCM_MAKINUM (ENOSYS);
+ scm_sysmissing (s_sys_nice);
+ /* not reached. */
+ return SCM_BOOL_F;
#endif
}
@@ -1345,8 +1439,11 @@ scm_sync()
{
#ifdef HAVE_SYNC
sync();
+#else
+ scm_sysmissing (s_sync);
+ /* not reached. */
#endif
- return SCM_UNSPECIFIED;
+ return SCM_BOOL_F;
}
diff --git a/libguile/posix.h b/libguile/posix.h
index 2bef059c8..904cc6236 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -44,15 +44,21 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
#ifdef __STDC__
+extern SCM scm_tcsetpgrp (SCM port, SCM pgid);
+extern SCM scm_tcgetpgrp (SCM port);
+extern SCM scm_ctermid (void);
+extern SCM scm_setsid (void);
+extern SCM scm_setpgid (SCM pid, SCM pgid);
extern SCM scm_sys_pipe (void);
extern SCM scm_sys_getgroups(void);
+extern SCM scm_getpgrp (void);
extern SCM scm_sys_getpwuid (SCM user);
extern SCM scm_setpwent (SCM arg);
extern SCM scm_sys_getgrgid (SCM name);
@@ -93,8 +99,14 @@ extern SCM scm_sync(void);
extern void scm_init_posix (void);
#else /* STDC */
+extern SCM scm_tcsetpgrp ();
+extern SCM scm_tcgetpgrp ();
+extern SCM scm_ctermid ();
+extern SCM scm_setsid ();
+extern SCM scm_setpgid ();
extern SCM scm_sys_pipe ();
extern SCM scm_sys_getgroups();
+extern SCM scm_getpgrp ();
extern SCM scm_sys_getpwuid ();
extern SCM scm_setpwent ();
extern SCM scm_sys_getgrgid ();
diff --git a/libguile/print.c b/libguile/print.c
index 0877f2ace..2b79c5bb4 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -42,9 +42,19 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "genio.h"
+#include "mbstrings.h"
+#include "smob.h"
+#include "eval.h"
+#include "procprop.h"
+#include "read.h"
+#include "weaks.h"
+#include "unif.h"
+#include "alist.h"
+#include "struct.h"
-
-
+#include "print.h"
/* {Names of immediate symbols}
@@ -88,21 +98,173 @@ char *scm_isymnames[] =
"#<unspecified>"
};
+scm_option scm_print_opts[] = {
+ { SCM_OPTION_SCM, "closure-hook", SCM_BOOL_F,
+ "Hook for printing closures." },
+ { SCM_OPTION_BOOLEAN, "source", 0,
+ "Print closures with source." }
+};
+
+SCM_PROC (s_print_options, "print-options-interface", 0, 1, 0, scm_print_options);
+#ifdef __STDC__
+SCM
+scm_print_options (SCM setting)
+#else
+SCM
+scm_print_options (setting)
+ SCM setting;
+#endif
+{
+ SCM ans = scm_options (setting,
+ scm_print_opts,
+ SCM_N_PRINT_OPTIONS,
+ s_print_options);
+ return ans;
+}
+
/* {Printing of Scheme Objects}
*/
-/* Print generally. Handles both write and display according to WRITING.
+/* Detection of circular references.
+ *
+ * Due to other constraints in the implementation, this code has bad
+ * time complexity (O (depth * N)), The printer code will be
+ * completely rewritten before next release of Guile. The new code
+ * will be O(N).
*/
+#define PUSH_REF(pstate, obj) \
+{ \
+ pstate->ref_stack[pstate->top++] = (obj); \
+ if (pstate->top == pstate->ceiling) \
+ grow_ref_stack (pstate); \
+}
+
+#define ENTER_NESTED_DATA(pstate, obj, label) \
+{ \
+ register int i; \
+ for (i = 0; i < pstate->top; ++i) \
+ if (pstate->ref_stack[i] == (obj)) \
+ goto label; \
+ if (pstate->fancyp) \
+ { \
+ if (pstate->top - pstate->list_offset >= pstate->level) \
+ { \
+ scm_gen_putc ('#', port); \
+ return; \
+ } \
+ } \
+ PUSH_REF(pstate, obj); \
+} \
+
+#define EXIT_NESTED_DATA(pstate) { --pstate->top; }
+
+static SCM print_state_pool;
+
+#if 1 /* Used for debugging purposes */
+SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate);
+#ifdef __STDC__
+SCM
+scm_current_pstate (void)
+#else
+SCM
+scm_current_pstate ()
+#endif
+{
+ return SCM_CADR (print_state_pool);
+}
+#endif
+
+#define PSTATE_SIZE 50L
+
+#ifdef __STDC__
+SCM
+scm_make_print_state (void)
+#else
+SCM
+scm_make_print_state ()
+#endif
+{
+ return scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */
+ SCM_MAKINUM (PSTATE_SIZE),
+ SCM_EOL);
+}
+
+#ifdef __STDC__
+static void
+grow_ref_stack (scm_print_state *pstate)
+#else
+static void
+grow_ref_stack (pstate)
+ scm_print_state *pstate;
+#endif
+{
+ int i, size = pstate->ceiling;
+ int total_size;
+ SCM handle;
+ SCM *data;
+ SCM_DEFER_INTS;
+ handle = pstate->handle;
+ data = (SCM *) pstate - scm_struct_n_extra_words;
+ total_size = ((SCM *) pstate)[scm_struct_i_n_words];
+ data = (SCM *) scm_must_realloc ((char *) data,
+ total_size,
+ total_size + size,
+ "grow_ref_stack");
+ pstate = (scm_print_state *) (data + scm_struct_n_extra_words);
+ ((SCM *) pstate)[scm_struct_i_n_words] = total_size + size;
+ pstate->ceiling += size;
+ for (i = size; i < pstate->ceiling; ++i)
+ pstate->ref_stack[i] = SCM_BOOL_F;
+ SCM_SETCDR (handle, pstate);
+ SCM_ALLOW_INTS;
+}
+
+#ifdef __STDC__
+static void
+print_circref (SCM port, scm_print_state *pstate, SCM ref)
+#else
+static void
+print_circref (port, pstate, ref)
+ SCM port;
+ scm_print_state *pstate;
+ SCM ref;
+#endif
+{
+ register int i;
+ int self = pstate->top - 1;
+ i = pstate->top - 1;
+ if (SCM_CONSP (pstate->ref_stack[i]))
+ {
+ while (i > 0)
+ {
+ if (SCM_NCONSP (pstate->ref_stack[i - 1])
+ || SCM_CDR (pstate->ref_stack[i - 1]) != pstate->ref_stack[i])
+ break;
+ --i;
+ }
+ self = i;
+ }
+ for (i = pstate->top - 1; 1; --i)
+ if (pstate->ref_stack[i] == ref)
+ break;
+ scm_gen_putc ('#', port);
+ scm_intprint (i - self, 10, port);
+ scm_gen_putc ('#', port);
+}
+
+/* Print generally. Handles both write and display according to PSTATE.
+ */
+
#ifdef __STDC__
void
-scm_iprin1 (SCM exp, SCM port, int writing)
+scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
#else
void
-scm_iprin1 (exp, port, writing)
+scm_iprin1 (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
register long i;
@@ -117,12 +279,12 @@ taloop:
if (SCM_ICHRP (exp))
{
i = SCM_ICHR (exp);
- scm_put_wchar (i, port, writing);
+ scm_put_wchar (i, port, SCM_WRITINGP (pstate));
}
- else if ( SCM_IFLAGP (exp)
+ else if (SCM_IFLAGP (exp)
&& (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
- scm_gen_puts (scm_regular_string, SCM_ISYMSCM_CHARS (exp), port);
+ scm_gen_puts (scm_regular_string, SCM_ISYMCHARS (exp), port);
else if (SCM_ILOCP (exp))
{
scm_gen_puts (scm_regular_string, "#@", port);
@@ -149,7 +311,7 @@ taloop:
if (SCM_CDR (SCM_CAR (exp) - 1L) == 0)
{
- scm_gen_write (scm_regular_string, "#<struct ", (scm_sizet) 9, port);
+ scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port);
scm_intprint(exp, 16, port);
scm_gen_putc ('>', port);
break;
@@ -157,49 +319,68 @@ taloop:
case scm_tcs_cons_imcar:
case scm_tcs_cons_nimcar:
- scm_iprlist ("(", exp, ')', port, writing);
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ scm_iprlist ("(", exp, ')', port, pstate);
+ EXIT_NESTED_DATA (pstate);
+ break;
+ circref:
+ print_circref (port, pstate, exp);
break;
case scm_tcs_closures:
-#ifdef DEBUG_EXTENSIONS
- if (PRINT_PROCNAMES)
+ if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)))
{
- SCM name;
+ SCM ans = scm_cons2 (exp, port,
+ scm_cons (SCM_WRITINGP (pstate)
+ ? SCM_BOOL_T
+ : SCM_BOOL_F,
+ SCM_EOL));
+ ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL);
+ }
+ else
+ {
+ SCM name, code;
name = scm_procedure_property (exp, scm_i_name);
- scm_gen_puts (scm_regular_string, "#<procedure", port);
- if (SCM_NFALSEP (name))
+ code = SCM_CODE (exp);
+ scm_gen_puts (scm_regular_string, "#<procedure ", port);
+ if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
{
+ scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
scm_gen_putc (' ', port);
- /* 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);
+ scm_iprin1 (SCM_CAR (code), port, pstate);
+ if (SCM_PRINT_SOURCE_P)
+ {
+ code = scm_unmemocopy (SCM_CDR (code),
+ SCM_EXTEND_ENV (SCM_CAR (code),
+ SCM_EOL,
+ SCM_ENV (exp)));
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ scm_iprlist (" ", code, '>', port, pstate);
+ EXIT_NESTED_DATA (pstate);
+ }
+ else
+ scm_gen_putc ('>', port);
}
break;
case scm_tc7_mb_string:
case scm_tc7_mb_substring:
- scm_print_mb_string (exp, port, writing);
+ scm_print_mb_string (exp, port, SCM_WRITINGP (pstate));
break;
case scm_tc7_substring:
case scm_tc7_string:
- if (writing)
+ if (SCM_WRITINGP (pstate))
{
- scm_gen_putc ('\"', port);
+ scm_gen_putc ('"', port);
for (i = 0; i < SCM_ROLENGTH (exp); ++i)
switch (SCM_ROCHARS (exp)[i])
{
- case '\"':
+ case '"':
case '\\':
scm_gen_putc ('\\', port);
default:
scm_gen_putc (SCM_ROCHARS (exp)[i], port);
}
- scm_gen_putc ('\"', port);
+ scm_gen_putc ('"', port);
break;
}
else
@@ -242,7 +423,7 @@ taloop:
#endif
case '(':
case ')':
- case '\"':
+ case '"':
case ';':
case SCM_WHITE_SPACES:
case SCM_LINE_INCREMENTORS:
@@ -293,6 +474,7 @@ taloop:
break;
}
case scm_tc7_wvect:
+ ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp))
scm_gen_puts (scm_regular_string, "#wh(", port);
else
@@ -300,20 +482,22 @@ taloop:
goto common_vector_printer;
case scm_tc7_vector:
+ ENTER_NESTED_DATA (pstate, exp, circref);
scm_gen_puts (scm_regular_string, "#(", port);
common_vector_printer:
for (i = 0; i + 1 < SCM_LENGTH (exp); ++i)
{
/* CHECK_INTS; */
- scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
+ scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
scm_gen_putc (' ', port);
}
if (i < SCM_LENGTH (exp))
{
/* CHECK_INTS; */
- scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
+ scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
}
scm_gen_putc (')', port);
+ EXIT_NESTED_DATA (pstate);
break;
case scm_tc7_bvect:
case scm_tc7_byvect:
@@ -326,7 +510,7 @@ taloop:
#ifdef LONGLONGS
case scm_tc7_llvect:
#endif
- scm_raprin1 (exp, port, writing);
+ scm_raprin1 (exp, port, pstate);
break;
case scm_tcs_subrs:
scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
@@ -339,7 +523,7 @@ taloop:
#ifdef CCLO
case scm_tc7_cclo:
scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
- scm_iprin1 (SCM_CCLO_SUBR (exp), port, writing);
+ scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate);
scm_gen_putc ('>', port);
break;
#endif
@@ -352,21 +536,69 @@ taloop:
break;
case scm_tc7_port:
i = SCM_PTOBNUM (exp);
- if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing))
+ if (i < scm_numptob
+ && scm_ptobs[i].print
+ && (scm_ptobs[i].print) (exp, port, pstate))
break;
goto punk;
case scm_tc7_smob:
+ ENTER_NESTED_DATA (pstate, exp, circref);
i = SCM_SMOBNUM (exp);
if (i < scm_numsmob && scm_smobs[i].print
- && (scm_smobs[i].print) (exp, port, writing))
- break;
- goto punk;
+ && (scm_smobs[i].print) (exp, port, pstate))
+ {
+ EXIT_NESTED_DATA (pstate);
+ break;
+ }
+ EXIT_NESTED_DATA (pstate);
default:
- punk:scm_ipruk ("type", exp, port);
+ punk:
+ scm_ipruk ("type", exp, port);
}
}
}
+/* Print states are necessary for circular reference safe printing.
+ * They are also expensive to allocate. Therefore print states are
+ * kept in a pool so that they can be reused.
+ */
+#ifdef __STDC__
+void
+scm_prin1 (SCM exp, SCM port, int writingp)
+#else
+void
+scm_prin1 (exp, port, writingp)
+ SCM exp;
+ SCM port;
+ int writingp;
+#endif
+{
+ SCM handle = 0; /* Will GC protect the handle whilst unlinked */
+ scm_print_state *pstate;
+
+ /* First try to allocate a print state from the pool */
+ SCM_DEFER_INTS;
+ if (SCM_NNULLP (SCM_CDR (print_state_pool)))
+ {
+ handle = SCM_CDR (print_state_pool);
+ SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
+ }
+ SCM_ALLOW_INTS;
+
+ if (!handle)
+ handle = scm_cons (scm_make_print_state (), SCM_EOL);
+
+ pstate = (scm_print_state *) SCM_STRUCT_DATA (SCM_CAR (handle));
+ pstate->writingp = writingp;
+ scm_iprin1 (exp, port, pstate);
+
+ /* Return print state to pool */
+ SCM_DEFER_INTS;
+ SCM_SETCDR (handle, SCM_CDR (print_state_pool));
+ SCM_SETCDR (print_state_pool, handle);
+ SCM_ALLOW_INTS;
+}
+
/* Print an integer.
*/
@@ -415,37 +647,115 @@ scm_ipruk (hdr, ptr, port)
/* Print a list.
*/
+
#ifdef __STDC__
void
-scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, int writing)
+scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, scm_print_state *pstate)
#else
void
-scm_iprlist (hdr, exp, tlr, port, writing)
+scm_iprlist (hdr, exp, tlr, port, pstate)
char *hdr;
SCM exp;
char tlr;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
+ register int i;
+ register SCM hare, tortoise;
+ int floor = pstate->top - 2;
scm_gen_puts (scm_regular_string, hdr, port);
/* CHECK_INTS; */
- scm_iprin1 (SCM_CAR (exp), port, writing);
+ if (pstate->fancyp)
+ goto fancy_printing;
+
+ /* Run a hare and tortoise so that total time complexity will be
+ O(depth * N) instead of O(N^2). */
+ hare = SCM_CDR (exp);
+ tortoise = exp;
+ while (SCM_NIMP (hare) && SCM_ECONSP (hare))
+ {
+ if (hare == tortoise)
+ goto fancy_printing;
+ hare = SCM_CDR (hare);
+ if (SCM_IMP (hare) || SCM_NECONSP (hare))
+ break;
+ hare = SCM_CDR (hare);
+ tortoise = SCM_CDR (tortoise);
+ }
+
+ /* No cdr cycles intrinsic to this list */
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
exp = SCM_CDR (exp);
for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
{
if (SCM_NECONSP (exp))
break;
+ for (i = floor; i >= 0; --i)
+ if (pstate->ref_stack[i] == exp)
+ goto circref;
+ PUSH_REF (pstate, exp);
scm_gen_putc (' ', port);
/* CHECK_INTS; */
- scm_iprin1 (SCM_CAR (exp), port, writing);
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
}
if (SCM_NNULLP (exp))
{
scm_gen_puts (scm_regular_string, " . ", port);
- scm_iprin1 (exp, port, writing);
+ scm_iprin1 (exp, port, pstate);
}
+
+end:
scm_gen_putc (tlr, port);
+ pstate->top = floor + 2;
+ return;
+
+fancy_printing:
+ {
+ int n = pstate->length;
+
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
+ exp = SCM_CDR (exp); --n;
+ for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
+ {
+ if (SCM_NECONSP (exp))
+ break;
+ for (i = 0; i < pstate->top; ++i)
+ if (pstate->ref_stack[i] == exp)
+ goto fancy_circref;
+ if (pstate->fancyp)
+ {
+ if (n == 0)
+ {
+ scm_gen_puts (scm_regular_string, " ...", port);
+ goto skip_tail;
+ }
+ else
+ --n;
+ }
+ PUSH_REF(pstate, exp);
+ ++pstate->list_offset;
+ scm_gen_putc (' ', port);
+ /* CHECK_INTS; */
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
+ }
+ }
+ if (SCM_NNULLP (exp))
+ {
+ scm_gen_puts (scm_regular_string, " . ", port);
+ scm_iprin1 (exp, port, pstate);
+ }
+skip_tail:
+ pstate->list_offset -= pstate->top - floor - 2;
+ goto end;
+
+fancy_circref:
+ pstate->list_offset -= pstate->top - floor - 2;
+
+circref:
+ scm_gen_puts (scm_regular_string, " . ", port);
+ print_circref (port, pstate, exp);
+ goto end;
}
@@ -465,7 +775,7 @@ scm_write (obj, port)
port = scm_cur_outp;
else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write);
- scm_iprin1 (obj, port, 1);
+ scm_prin1 (obj, port, 1);
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
@@ -491,7 +801,7 @@ scm_display (obj, port)
port = scm_cur_outp;
else
SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
- scm_iprin1 (obj, port, 0);
+ scm_prin1 (obj, port, 0);
#ifdef HAVE_PIPE
# ifdef EPIPE
if (EPIPE == errno)
@@ -565,6 +875,13 @@ void
scm_init_print ()
#endif
{
+ SCM vtable, type;
+ scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
+ vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_makfrom0str ("")), SCM_INUM0, SCM_EOL);
+ type = scm_make_struct (vtable,
+ SCM_INUM0,
+ scm_cons (scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)),
+ SCM_EOL));
+ print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL));
#include "print.x"
}
-
diff --git a/libguile/print.h b/libguile/print.h
index ae23eaf00..017c8f766 100644
--- a/libguile/print.h
+++ b/libguile/print.h
@@ -44,14 +44,50 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+#include "libguile/options.h"
+extern scm_option scm_print_opts[];
+
+#define SCM_PRINT_CLOSURE ((SCM) scm_print_opts[0].val)
+#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val)
+#define SCM_N_PRINT_OPTIONS 2
+
+/* State information passed around during printing.
+ */
+#define RESET_PRINT_STATE(pstate) \
+{ \
+ pstate->list_offset = 0; \
+ pstate->top = 0; \
+}
+
+#define SCM_WRITINGP(pstate) ((pstate)->writingp)
+#define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); }
+
+#define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwpwuwuwuwpW"
+typedef struct scm_print_state {
+ SCM handle; /* Struct handle */
+ unsigned long writingp; /* Writing? */
+ unsigned long fancyp; /* Fancy printing? */
+ unsigned long level; /* Max level */
+ unsigned long length; /* Max number of objects per level */
+ SCM hot_ref; /* Hot reference */
+ unsigned long list_offset;
+ unsigned long top; /* Top of reference stack */
+ unsigned long ceiling; /* Max size of reference stack */
+ unsigned long n_refs; /* Size of struct tail array */
+ SCM ref_stack[1]; /* Stack of references used during
+ circular reference detection */
+} scm_print_state;
+
#ifdef __STDC__
+extern SCM scm_print_options (SCM setting);
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 void scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, scm_print_state *pstate);
+extern void scm_prin1 (SCM exp, SCM port, int writingp);
+extern void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate);
extern SCM scm_write (SCM obj, SCM port);
extern SCM scm_display (SCM obj, SCM port);
extern SCM scm_newline(SCM port);
@@ -59,9 +95,11 @@ extern SCM scm_write_char (SCM chr, SCM port);
extern void scm_init_print (void);
#else /* STDC */
+extern SCM scm_print_options ();
extern void scm_intprint ();
extern void scm_ipruk ();
extern void scm_iprlist ();
+extern void scm_prin1 ();
extern void scm_iprin1 ();
extern SCM scm_write ();
extern SCM scm_display ();
diff --git a/libguile/procprop.c b/libguile/procprop.c
index a984008db..ecf10a92a 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -42,7 +42,10 @@
#include <stdio.h>
#include "_scm.h"
+#include "alist.h"
+#include "eval.h"
+#include "procprop.h"
static SCM
diff --git a/libguile/procprop.h b/libguile/procprop.h
index ee6f37cb3..76e46bef3 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/procs.c b/libguile/procs.c
index 6c5a5b2c4..ae23e663e 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -43,7 +43,7 @@
#include <stdio.h>
#include "_scm.h"
-
+#include "procs.h"
@@ -144,6 +144,36 @@ scm_procedure_p (obj)
return SCM_BOOL_F;
}
+#ifdef __STDC__
+SCM
+scm_thunk_p (SCM obj)
+#else
+SCM
+scm_thunk_p (obj)
+ SCM obj;
+#endif
+{
+ if (SCM_NIMP (obj))
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tcs_closures:
+ if (SCM_NULLP (SCM_CAR (SCM_CODE (obj))))
+ return SCM_BOOL_T;
+ case scm_tc7_subr_0:
+ case scm_tc7_subr_1o:
+ case scm_tc7_lsubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+ return SCM_BOOL_T;
+ default:
+ ;
+ }
+ return SCM_BOOL_F;
+}
+
#ifdef __STDC__
void
diff --git a/libguile/procs.h b/libguile/procs.h
index 332e06c1f..86d64f103 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -91,15 +91,19 @@ typedef struct scm_dsubr
#ifdef __STDC__
extern SCM scm_make_subr (char *name, int type, SCM (*fcn) ());
+extern SCM scm_make_subr_opt (char *name, int type, SCM (*fcn) (), int set);
extern SCM scm_makcclo (SCM proc, long len);
extern SCM scm_procedure_p (SCM obj);
+extern SCM scm_thunk_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_make_subr_opt ();
extern SCM scm_makcclo ();
extern SCM scm_procedure_p ();
+extern SCM scm_thunk_p ();
extern void scm_init_iprocs();
extern void scm_init_procs ();
diff --git a/libguile/ramap.c b/libguile/ramap.c
index a913da0e6..9a968fae3 100644
--- a/libguile/ramap.c
+++ b/libguile/ramap.c
@@ -45,7 +45,14 @@
#include <stdio.h>
#include "_scm.h"
-
+#include "unif.h"
+#include "smob.h"
+#include "chars.h"
+#include "eq.h"
+#include "eval.h"
+#include "feature.h"
+
+#include "ramap.h"
#ifdef ARRAYS
diff --git a/libguile/ramap.h b/libguile/ramap.h
index a198f59ee..d558a9d4e 100644
--- a/libguile/ramap.h
+++ b/libguile/ramap.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
#ifdef __STDC__
@@ -52,7 +52,7 @@ 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 SCM scm_array_copy_x (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);
@@ -75,7 +75,7 @@ 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 SCM scm_array_copy_x ();
extern int scm_ra_eqp ();
extern int scm_ra_lessp ();
extern int scm_ra_leqp ();
diff --git a/libguile/read.c b/libguile/read.c
index 1340fc1f4..3f29a676c 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -43,6 +43,17 @@
#include "extchrs.h"
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "genio.h"
+#include "eval.h"
+#include "unif.h"
+#include "mbstrings.h"
+#include "kw.h"
+#include "alist.h"
+#include "srcprop.h"
+#include "hashtab.h"
+#include "hash.h"
+
#include "read.h"
@@ -51,30 +62,59 @@
+scm_option scm_read_opts[] = {
+ { SCM_OPTION_BOOLEAN, "copy", 0,
+ "Copy source code expressions." },
+ { SCM_OPTION_BOOLEAN, "positions", 0,
+ "Record positions of source code expressions." }
+};
+
+SCM_PROC (s_read_options, "read-options-interface", 0, 1, 0, scm_read_options);
+#ifdef __STDC__
+SCM
+scm_read_options (SCM setting)
+#else
+SCM
+scm_read_options (setting)
+ SCM setting;
+#endif
+{
+ SCM ans = scm_options (setting,
+ scm_read_opts,
+ SCM_N_READ_OPTIONS,
+ s_read_options);
+ if (SCM_COPY_SOURCE_P)
+ SCM_RECORD_POSITIONS_P = 1;
+ return ans;
+}
+
SCM_PROC (s_read, "read", 0, 3, 0, scm_read);
#ifdef __STDC__
SCM
-scm_read (SCM port, SCM case_insensative_p, SCM sharp)
+scm_read (SCM port, SCM case_insensitive_p, SCM sharp)
#else
SCM
-scm_read (port, case_insensative_p, sharp)
+scm_read (port, case_insensitive_p, sharp)
SCM port;
- SCM case_insensative_p;
+ SCM case_insensitive_p;
SCM sharp;
#endif
{
int c;
- SCM tok_buf;
+ SCM tok_buf, copy;
int case_i;
if (SCM_UNBNDP (port))
port = scm_cur_inp;
else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read);
+ SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
+ port,
+ SCM_ARG1,
+ s_read);
- case_i = (SCM_UNBNDP (case_insensative_p)
+ case_i = (SCM_UNBNDP (case_insensitive_p)
? default_case_i
- : (case_insensative_p == SCM_BOOL_F));
+ : (case_insensitive_p == SCM_BOOL_F));
if (SCM_UNBNDP (sharp))
sharp = SCM_BOOL_F;
@@ -85,7 +125,7 @@ scm_read (port, case_insensative_p, sharp)
scm_gen_ungetc (c, port);
tok_buf = scm_makstr (30L, 0);
- return scm_lreadr (&tok_buf, port, case_i, sharp);
+ return scm_lreadr (&tok_buf, port, case_i, sharp, &copy);
}
@@ -98,22 +138,7 @@ 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;
+ scm_vector_set_length_x (*tok_buf, SCM_MAKINUM (2 * SCM_LENGTH (*tok_buf)));
return SCM_CHARS (*tok_buf);
}
@@ -150,12 +175,8 @@ scm_flush_ws (port, eoferr)
}
break;
case SCM_LINE_INCREMENTORS:
- break;
case SCM_SINGLE_SPACES:
- SCM_INCCOL (port);
- break;
case '\t':
- SCM_TABCOL (port);
break;
default:
return c;
@@ -185,16 +206,73 @@ scm_casei_streq (s1, s2)
}
+/* recsexpr is used when recording expressions
+ * constructed by read:sharp.
+ */
+#ifdef __STDC__
+static SCM
+recsexpr (SCM obj, int line, int column, SCM filename)
+#else
+static SCM
+recsexpr (obj, line, column, filename)
+ SCM obj;
+ int line;
+ int column;
+ SCM filename;
+#endif
+{
+ if (SCM_IMP (obj) || SCM_NCONSP(obj))
+ return obj;
+ {
+ SCM tmp = obj, copy;
+ /* If this sexpr is visible in the read:sharp source, we want to
+ keep that information, so only record non-constant cons cells
+ which haven't previously been read by the reader. */
+ if (SCM_FALSEP (scm_whash_lookup (scm_source_whash, obj)))
+ {
+ if (SCM_COPY_SOURCE_P)
+ {
+ copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
+ SCM_UNDEFINED);
+ while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp))
+ copy = (SCM_CDR (copy) = scm_cons (recsexpr (SCM_CAR (tmp),
+ line,
+ column,
+ filename),
+ SCM_UNDEFINED));
+ SCM_CDR (copy) = tmp;
+ }
+ else
+ {
+ recsexpr (SCM_CAR (obj), line, column, filename);
+ while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp))
+ recsexpr (SCM_CAR (tmp), line, column, filename);
+ copy = SCM_UNDEFINED;
+ }
+ scm_whash_insert (scm_source_whash,
+ obj,
+ scm_make_srcprops (line,
+ column,
+ filename,
+ copy,
+ SCM_EOL));
+ }
+ return obj;
+ }
+}
+
+static char s_list[]="list";
#ifdef __STDC__
SCM
-scm_lreadr (SCM * tok_buf, SCM port, int case_i, SCM sharp)
+scm_lreadr (SCM *tok_buf, SCM port, int case_i, SCM sharp, SCM *copy)
#else
SCM
-scm_lreadr (tok_buf, port, case_i, sharp)
- SCM * tok_buf;
+scm_lreadr (tok_buf, port, case_i, sharp, copy)
+ SCM *tok_buf;
SCM port;
int case_i;
SCM sharp;
+ SCM *copy;
#endif
{
int c;
@@ -209,18 +287,19 @@ tryagain:
return SCM_EOF_VAL;
case '(':
- return scm_lreadparen (tok_buf, port, "list", case_i, sharp);
-
+ return SCM_RECORD_POSITIONS_P
+ ? scm_lreadrecparen (tok_buf, port, s_list, case_i, sharp, copy)
+ : scm_lreadparen (tok_buf, port, s_list, case_i, sharp, copy);
case ')':
scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read");
goto tryagain;
case '\'':
- return scm_cons2 (scm_i_quote, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL);
-
+ p = scm_i_quote;
+ goto recquote;
case '`':
- return scm_cons2 (scm_i_quasiquote, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL);
-
+ p = scm_i_quasiquote;
+ goto recquote;
case ',':
c = scm_gen_getc (port);
if ('@' == c)
@@ -230,14 +309,29 @@ tryagain:
scm_gen_ungetc (c, port);
p = scm_i_unquote;
}
- return scm_cons2 (p, scm_lreadr (tok_buf, port, case_i, sharp), SCM_EOL);
-
+ recquote:
+ p = scm_cons2 (p,
+ scm_lreadr (tok_buf, port, case_i, sharp, copy),
+ SCM_EOL);
+ if (SCM_RECORD_POSITIONS_P)
+ scm_whash_insert (scm_source_whash,
+ p,
+ scm_make_srcprops (SCM_LINUM (port),
+ SCM_COL (port) - 1,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (*copy = scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
+ return p;
case '#':
c = scm_gen_getc (port);
switch (c)
{
case '(':
- p = scm_lreadparen (tok_buf, port, "vector", case_i, sharp);
+ p = scm_lreadparen (tok_buf, port, "vector", case_i, sharp, copy);
return SCM_NULLP (p) ? scm_nullvect : scm_vector (p);
case 't':
@@ -300,11 +394,19 @@ tryagain:
callshrp:
if (SCM_NIMP (sharp))
{
+ int line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 2;
SCM got;
- got = scm_apply (sharp, SCM_MAKICHR (c), scm_acons (port, SCM_EOL, SCM_EOL));
+ got = scm_apply (sharp,
+ SCM_MAKICHR (c),
+ scm_acons (port, SCM_EOL, SCM_EOL));
if (SCM_UNSPECIFIED == got)
goto unkshrp;
- return got;
+ if (SCM_RECORD_POSITIONS_P)
+ return *copy = recsexpr (got, line, column,
+ SCM_FILENAME (port));
+ else
+ return got;
}
unkshrp:scm_wta ((SCM) SCM_MAKICHR (c), "unknown # object", "");
}
@@ -538,10 +640,10 @@ _Pragma ("opt"); /* # pragma _CRI opt */
#ifdef __STDC__
SCM
-scm_lreadparen (SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp)
+scm_lreadparen (SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy)
#else
SCM
-scm_lreadparen (tok_buf, port, name, case_i, sharp)
+scm_lreadparen (tok_buf, port, name, case_i, sharp, SCM *copy)
SCM *tok_buf;
SCM port;
char *name;
@@ -558,9 +660,9 @@ scm_lreadparen (tok_buf, port, name, case_i, sharp)
if (')' == c)
return SCM_EOL;
scm_gen_ungetc (c, port);
- if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp)))
+ if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)))
{
- ans = scm_lreadr (tok_buf, port, case_i, sharp);
+ ans = scm_lreadr (tok_buf, port, case_i, sharp, copy);
closeit:
if (')' != (c = scm_flush_ws (port, name)))
scm_wta (SCM_UNDEFINED, "missing close paren", "");
@@ -570,9 +672,9 @@ scm_lreadparen (tok_buf, port, name, case_i, sharp)
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)))
+ if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)))
{
- SCM_CDR (tl) = scm_lreadr (tok_buf, port, case_i, sharp);
+ SCM_CDR (tl) = scm_lreadr (tok_buf, port, case_i, sharp, copy);
goto closeit;
}
tl = (SCM_CDR (tl) = scm_cons (tmp, SCM_EOL));
@@ -580,6 +682,81 @@ scm_lreadparen (tok_buf, port, name, case_i, sharp)
return ans;
}
+#ifdef __STDC__
+SCM
+scm_lreadrecparen (SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy)
+#else
+SCM
+scm_lreadrecparen (tok_buf, port, name, case_i, sharp, copy)
+ SCM *tok_buf;
+ SCM port;
+ char *name;
+ int case_i;
+ SCM sharp;
+ SCM *copy;
+#endif
+{
+ register int c;
+ register SCM tmp;
+ register SCM tl, tl2;
+ SCM ans, ans2;
+ /* Need to capture line and column numbers here. */
+ int line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+
+ c = scm_flush_ws (port, name);
+ if (')' == c)
+ return SCM_EOL;
+ scm_gen_ungetc (c, port);
+ if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)))
+ {
+ ans = scm_lreadr (tok_buf, port, case_i, sharp, copy);
+ if (')' != (c = scm_flush_ws (port, name)))
+ scm_wta (SCM_UNDEFINED, "missing close paren", "");
+ return ans;
+ }
+ /* Build the head of the list structure. */
+ ans = tl = scm_cons (tmp, SCM_EOL);
+ if (SCM_COPY_SOURCE_P)
+ ans2 = tl2 = scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
+ ? *copy
+ : tmp,
+ SCM_EOL);
+ while (')' != (c = scm_flush_ws (port, name)))
+ {
+ scm_gen_ungetc (c, port);
+ if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)))
+ {
+ SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy));
+ if (SCM_COPY_SOURCE_P)
+ SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
+ ? *copy
+ : tmp,
+ SCM_EOL));
+ if (')' != (c = scm_flush_ws (port, name)))
+ scm_wta (SCM_UNDEFINED, "missing close paren", "");
+ goto exit;
+ }
+ tl = SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL));
+ if (SCM_COPY_SOURCE_P)
+ tl2 = SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
+ ? *copy
+ : tmp,
+ SCM_EOL));
+ }
+exit:
+ scm_whash_insert (scm_source_whash,
+ ans,
+ scm_make_srcprops (line,
+ column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? *copy = ans2
+ : SCM_UNDEFINED,
+ SCM_EOL));
+ return ans;
+}
+
@@ -592,6 +769,6 @@ void
scm_init_read ()
#endif
{
+ scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
#include "read.x"
}
-
diff --git a/libguile/read.h b/libguile/read.h
index edaea932b..97dddd005 100644
--- a/libguile/read.h
+++ b/libguile/read.h
@@ -44,8 +44,9 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+#include "libguile/options.h"
/* SCM_LINE_INCREMENTORS are the characters which cause the line count to
@@ -66,19 +67,28 @@
#define SCM_WHITE_SPACES SCM_SINGLE_SPACES: case '\t'
+extern scm_option scm_read_opts[];
+
+#define SCM_COPY_SOURCE_P scm_read_opts[0].val
+#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val
+#define SCM_N_READ_OPTIONS 2
+
#ifdef __STDC__
+extern SCM scm_read_options (SCM setting);
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 scm_lreadr (SCM * tok_buf, SCM port, int case_i, SCM sharp, SCM *copy);
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 SCM scm_lreadparen (SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy);
+extern SCM scm_lreadrecparen (SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy);
extern void scm_init_read (void);
#else /* STDC */
+extern SCM scm_read_options ();
extern SCM scm_read ();
extern char * scm_grow_tok_buf ();
extern int scm_flush_ws ();
@@ -86,6 +96,7 @@ extern int scm_casei_streq ();
extern SCM scm_lreadr ();
extern scm_sizet scm_read_token ();
extern SCM scm_lreadparen ();
+extern SCM scm_lreadrecparen ();
extern void scm_init_read ();
#endif /* STDC */
diff --git a/libguile/root.c b/libguile/root.c
index 9db2e9b18..9fb6fbd8b 100644
--- a/libguile/root.c
+++ b/libguile/root.c
@@ -42,16 +42,235 @@
#include <stdio.h>
#include "_scm.h"
+#include "stackchk.h"
+#include "dynwind.h"
+#include "eval.h"
+#include "genio.h"
+#include "smob.h"
+#include "pairs.h"
+#include "throw.h"
+#include "root.h"
SCM scm_sys_protects[SCM_NUM_PROTECTS];
-struct scm_root_state the_scm_root;
-struct scm_root_state * scm_root = &the_scm_root;
+
+long scm_tc16_root;
+
+#ifndef USE_THREADS
+struct scm_root_state *scm_root;
+#endif
+static SCM mark_root SCM_P ((SCM));
+
+static SCM
+mark_root (root)
+ SCM root;
+{
+ scm_root_state *s = SCM_ROOT_STATE (root);
+ SCM_SETGC8MARK (root);
+ scm_gc_mark (s->rootcont);
+ scm_gc_mark (s->dynwinds);
+ scm_gc_mark (s->continuation_stack);
+ scm_gc_mark (s->continuation_stack_ptr);
+ scm_gc_mark (s->progargs);
+ scm_gc_mark (s->exitval);
+ scm_gc_mark (s->cur_inp);
+ scm_gc_mark (s->cur_outp);
+ scm_gc_mark (s->cur_errp);
+ scm_gc_mark (s->def_inp);
+ scm_gc_mark (s->def_outp);
+ scm_gc_mark (s->def_errp);
+ scm_gc_mark (s->top_level_lookup_thunk_var);
+ scm_gc_mark (s->system_transformer);
+ return SCM_ROOT_STATE (root) -> parent;
+}
+static scm_sizet free_root SCM_P ((SCM));
+
+static scm_sizet
+free_root (root)
+ SCM root;
+{
+ scm_must_free ((char *) SCM_ROOT_STATE (root));
+ return sizeof (scm_root_state);
+}
+
+static int print_root SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
+
+static int
+print_root (exp, port, pstate)
+ SCM exp;
+ SCM port;
+ scm_print_state *pstate;
+{
+ scm_gen_puts (scm_regular_string, "#<root ", port);
+ scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
+ scm_gen_putc('>', port);
+ return 1;
+}
+
+static scm_smobfuns root_smob =
+{
+ mark_root,
+ free_root,
+ print_root,
+ 0
+};
+
+
+
+SCM
+scm_make_root (parent)
+ SCM parent;
+{
+ SCM root;
+ scm_root_state *root_state;
+
+ root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state),
+ "scm_make_root");
+ if (SCM_NIMP (parent) && SCM_ROOTP (parent))
+ {
+ memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
+ root_state->parent = parent;
+ }
+ else
+ {
+ root_state->parent = SCM_BOOL_F;
+ }
+ SCM_NEWCELL (root);
+ SCM_REDEFER_INTS;
+ SCM_SETCAR (root, scm_tc16_root);
+ SCM_SETCDR (root, root_state);
+ root_state->handle = root;
+ SCM_REALLOW_INTS;
+ return root;
+}
+
+/* {call-with-new-root}
+ *
+ * Suspending the current thread to evaluate a thunk on the
+ * same C stack but under a new root.
+ *
+ * Calls to call-with-new-root return exactly once (unless
+ * the process is somehow exitted).
+ */
+
+#if 0
+SCM scm_exitval; /* INUM with return value */
+#endif
+static int n_dynamic_roots = 0;
+
+static SCM cwdr SCM_P ((SCM thunk, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start));
+
+/* This is the basic code for new root creation.
+ *
+ * WARNING! The order of actions in this routine is in many ways
+ * critical. E. g., it is essential that an error doesn't leave Guile
+ * in a messed up state.
+ */
+
+static SCM
+cwdr (proc, a1, args, handler, stack_start)
+ SCM proc;
+ SCM a1;
+ SCM args;
+ SCM handler;
+ SCM_STACKITEM *stack_start;
+{
+ int old_ints_disabled = scm_ints_disabled;
+ SCM old_rootcont, old_winds;
+ SCM answer;
+
+ /* Create a fresh root continuation.
+ */
+ {
+ SCM new_rootcont;
+ SCM_NEWCELL (new_rootcont);
+ SCM_REDEFER_INTS;
+ SCM_SETJMPBUF (new_rootcont,
+ scm_must_malloc ((long) sizeof (regs),
+ "inferior root continuation"));
+ SCM_CAR (new_rootcont) = scm_tc7_contin;
+ SCM_DYNENV (new_rootcont) = SCM_EOL;
+ SCM_BASE (new_rootcont) = stack_start;
+ SCM_SEQ (new_rootcont) = ++n_dynamic_roots;
+#ifdef DEBUG_EXTENSIONS
+ SCM_DFRAME (new_rootcont) = 0;
+#endif
+ old_rootcont = scm_rootcont;
+ scm_rootcont = new_rootcont;
+ SCM_REALLOW_INTS;
+ }
+
+ /* Exit caller's dynamic state.
+ */
+ old_winds = scm_dynwinds;
+ scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
+#ifdef DEBUG_EXTENSIONS
+ scm_last_debug_frame = 0;
+#endif
+
+ /* Catch all errors. */
+ answer = scm_catch_apply (SCM_BOOL_T, proc, a1, args, handler);
+
+ scm_dowinds (old_winds, - scm_ilength (old_winds));
+ SCM_REDEFER_INTS;
+ scm_rootcont = old_rootcont;
+#ifdef DEBUG_EXTENSIONS
+ scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
+#endif
+ SCM_REALLOW_INTS;
+ scm_ints_disabled = old_ints_disabled;
+ return answer;
+}
+
+
+SCM_PROC(s_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root);
+#ifdef __STDC__
+SCM
+scm_call_with_dynamic_root (SCM thunk, SCM handler)
+#else
+SCM
+scm_call_with_dynamic_root (thunk, handler)
+ SCM thunk;
+ SCM handler;
+#endif
+{
+ SCM_STACKITEM stack_place;
+
+ return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
+}
+
+SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root);
+#ifdef __STDC__
+SCM
+scm_dynamic_root (void)
+#else
+SCM
+scm_dynamic_root ()
+#endif
+{
+ return scm_ulong2num (SCM_SEQ (scm_root->rootcont));
+}
+
+#ifdef __STDC__
+SCM
+scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
+#else
+SCM
+scm_apply_with_dynamic_root (proc, a1, args, handler)
+ SCM proc;
+ SCM a1;
+ SCM args;
+ SCM error;
+#endif
+{
+ SCM_STACKITEM stack_place;
+ return cwdr (proc, a1, args, handler, &stack_place);
+}
@@ -70,18 +289,24 @@ typedef long setjmp_type;
#ifdef __STDC__
SCM
-scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void * closure)
+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;
+ void *closure;
#endif
{
SCM answer;
setjmp_type i;
+#ifdef DEBUG_EXTENSIONS
+ SCM_DFRAME (scm_rootcont) = scm_last_debug_frame;
+#endif
i = setjmp (SCM_JMPBUF (scm_rootcont));
+#ifdef STACK_CHECKING
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+#endif
if (!i)
{
scm_gc_heap_lock = 0;
@@ -95,7 +320,9 @@ scm_call_catching_errors (thunk, err_filter, closure)
return answer;
}
-
-
-
-
+void
+scm_init_root ()
+{
+ scm_tc16_root = scm_newsmob (&root_smob);
+#include "root.x"
+}
diff --git a/libguile/root.h b/libguile/root.h
index 370563dad..b71305563 100644
--- a/libguile/root.h
+++ b/libguile/root.h
@@ -47,7 +47,8 @@
-#include "__scm.h"
+#include "libguile/__scm.h"
+#include "libguile/debug.h"
@@ -66,13 +67,23 @@
#define scm_object_whash scm_sys_protects[12]
#define scm_permobjs scm_sys_protects[13]
#define scm_asyncs scm_sys_protects[14]
+#ifdef DEBUG_EXTENSIONS
+#define scm_source_whash scm_sys_protects[15]
+#define SCM_NUM_PROTECTS 16
+#else
#define SCM_NUM_PROTECTS 15
+#endif
extern SCM scm_sys_protects[];
-struct scm_root_state
+extern long scm_tc16_root;
+
+#define SCM_ROOTP(obj) (scm_tc16_root == SCM_TYP16 (obj))
+#define SCM_ROOT_STATE(root) ((scm_root_state *) SCM_CDR (root))
+
+typedef struct scm_root_state
{
SCM_STACKITEM * stack_base;
jmp_buf save_regs_gc_mark;
@@ -82,7 +93,11 @@ struct scm_root_state
SCM dynwinds;
SCM continuation_stack;
SCM continuation_stack_ptr;
-
+#ifdef DEBUG_EXTENSIONS
+ /* It is very inefficient to have this variable in the root state. */
+ scm_debug_frame *last_debug_frame;
+#endif
+
SCM progargs; /* vestigial */
SCM exitval; /* vestigial */
@@ -95,7 +110,10 @@ struct scm_root_state
SCM system_transformer;
SCM top_level_lookup_thunk_var;
-};
+
+ SCM handle; /* The root object for this root state */
+ SCM parent; /* The parent root object */
+} scm_root_state;
#define scm_stack_base (scm_root->stack_base)
#define scm_save_regs_gc_mark (scm_root->save_regs_gc_mark)
@@ -106,6 +124,9 @@ struct scm_root_state
#define scm_continuation_stack (scm_root->continuation_stack)
#define scm_continuation_stack_ptr (scm_root->continuation_stack_ptr)
#define scm_progargs (scm_root->progargs)
+#ifdef USE_THREADS
+#define scm_last_debug_frame (scm_root->last_debug_frame)
+#endif
#define scm_exitval (scm_root->exitval)
#define scm_cur_inp (scm_root->cur_inp)
#define scm_cur_outp (scm_root->cur_outp)
@@ -116,23 +137,20 @@ struct scm_root_state
#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 USE_THREADS
+#define scm_root ((scm_root_state *) SCM_THREAD_LOCAL_DATA)
+#define scm_set_root(new_root) SCM_SET_THREAD_LOCAL_DATA (new_root)
+#else /* USE_THREADS */
+extern struct scm_root_state *scm_root;
+#define scm_set_root(new_root) (scm_root = (new_root))
+#endif /* USE_THREADS */
-
-#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 */
-
-
-
-
-
+extern SCM scm_make_root SCM_P ((SCM parent));
+extern SCM scm_call_with_dynamic_root SCM_P ((SCM thunk, SCM handler));
+extern SCM scm_apply_with_dynamic_root SCM_P ((SCM proc, SCM a1, SCM args, SCM handler));
+extern SCM scm_call_catching_errors SCM_P ((SCM (*thunk)(), SCM (*err_filter)(), void * closure));
+extern void scm_init_root SCM_P ((void));
#endif /* ROOTH */
diff --git a/libguile/scmconfig.h.in b/libguile/scmconfig.h.in
index af237dbdc..b17472c40 100644
--- a/libguile/scmconfig.h.in
+++ b/libguile/scmconfig.h.in
@@ -32,6 +32,9 @@
/* Define if on MINIX. */
#undef _MINIX
+/* Define to `int' if <sys/types.h> doesn't define. */
+#undef mode_t
+
/* Define if the system does not provide POSIX.1 features except
with this defined. */
#undef _POSIX_1_SOURCE
@@ -51,6 +54,56 @@
/* Define to `int' if <sys/types.h> doesn't define. */
#undef uid_t
+/* Define these two if you want support for debugging of Scheme
+ programs. */
+#undef DEBUG_EXTENSIONS
+#undef READER_EXTENSIONS
+
+/* Define this if your system has a way to set a stdio stream's file
+ descriptor. You should also copy fd.h.in to fd.h, and give the
+ macro SET_FILE_FD_FIELD an appropriate definition. See
+ configure.in for more details. */
+#undef HAVE_FD_SETTER
+
+/* Define this if your system defines struct linger, for use with the
+ getsockopt and setsockopt system calls. */
+#undef HAVE_STRUCT_LINGER
+
+/* Define this if floats are the same size as longs. */
+#undef SCM_SINGLES
+
+/* Define this if a callee's stack frame has a higher address than the
+ caller's stack frame. On most machines, this is not the case. */
+#undef SCM_STACK_GROWS_UP
+
+/* Define this if <utime.h> doesn't define struct utimbuf unless
+ _POSIX_SOURCE is #defined. */
+#undef UTIMBUF_NEEDS_POSIX
+
+/* Define these to indicate the current version of Guile. These
+ values are supposed to be supplied by the configuration system. */
+#undef GUILE_MAJOR_VERSION
+#undef GUILE_MINOR_VERSION
+#undef GUILE_VERSION
+
+/* Define if using cooperative multithreading. */
+#undef USE_COOP_THREADS
+
+/* Define if using "FSU" pthreads. */
+#undef USE_FSU_PTHREADS
+
+/* Define if using MIT pthreads. */
+#undef USE_MIT_PTHREADS
+
+/* Define if using PCthreads pthreads. */
+#undef USE_PCTHREADS_PTHREADS
+
+/* Define if using any sort of threads. */
+#undef USE_THREADS
+
+/* Define if you have the ctermid function. */
+#undef HAVE_CTERMID
+
/* Define if you have the ftime function. */
#undef HAVE_FTIME
@@ -87,9 +140,21 @@
/* Define if you have the select function. */
#undef HAVE_SELECT
+/* Define if you have the setegid function. */
+#undef HAVE_SETEGID
+
+/* Define if you have the seteuid function. */
+#undef HAVE_SETEUID
+
/* Define if you have the setlocale function. */
#undef HAVE_SETLOCALE
+/* Define if you have the setpgid function. */
+#undef HAVE_SETPGID
+
+/* Define if you have the setsid function. */
+#undef HAVE_SETSID
+
/* Define if you have the strftime function. */
#undef HAVE_STRFTIME
@@ -102,15 +167,27 @@
/* Define if you have the sync function. */
#undef HAVE_SYNC
+/* Define if you have the tcgetpgrp function. */
+#undef HAVE_TCGETPGRP
+
+/* Define if you have the tcsetpgrp function. */
+#undef HAVE_TCSETPGRP
+
/* Define if you have the times function. */
#undef HAVE_TIMES
/* Define if you have the uname function. */
#undef HAVE_UNAME
+/* Define if you have the waitpid function. */
+#undef HAVE_WAITPID
+
/* Define if you have the <dirent.h> header file. */
#undef HAVE_DIRENT_H
+/* Define if you have the <libc.h> header file. */
+#undef HAVE_LIBC_H
+
/* Define if you have the <limits.h> header file. */
#undef HAVE_LIMITS_H
@@ -129,6 +206,9 @@
/* Define if you have the <sys/dir.h> header file. */
#undef HAVE_SYS_DIR_H
+/* Define if you have the <sys/ioctl.h> header file. */
+#undef HAVE_SYS_IOCTL_H
+
/* Define if you have the <sys/ndir.h> header file. */
#undef HAVE_SYS_NDIR_H
@@ -147,13 +227,14 @@
/* Define if you have the <sys/types.h> header file. */
#undef HAVE_SYS_TYPES_H
+/* Define if you have the <sys/utime.h> header file. */
+#undef HAVE_SYS_UTIME_H
+
/* Define if you have the <time.h> header file. */
#undef HAVE_TIME_H
/* Define if you have the <unistd.h> header file. */
#undef HAVE_UNISTD_H
-#undef SCM_SINGLES
-
-#undef SCM_STACK_GROWS_UP
-
+/* Define if you have the <utime.h> header file. */
+#undef HAVE_UTIME_H
diff --git a/libguile/scmhob.h b/libguile/scmhob.h
index 127f4d5c1..063938d90 100644
--- a/libguile/scmhob.h
+++ b/libguile/scmhob.h
@@ -22,7 +22,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#include <stdio.h>
#include <ctype.h>
-#include "_scm.h"
+#include "libguile/_scm.h"
@@ -131,7 +131,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#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 SCM_CHAR_NUMP(chr) ((isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
#define CHAR_WHITEP(chr) ((isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
#define CHAR_UPPERP(chr) ((isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
#define CHAR_LOWERP(chr) ((isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
@@ -139,9 +139,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#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_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))
+#define VECTOR_LENGTH(v) SCM_MAKINUM(SCM_LENGTH(v))
#ifdef SCM_FLOATS
#include <math.h>
diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c
index bb7f740f9..d04934435 100644
--- a/libguile/scmsigs.c
+++ b/libguile/scmsigs.c
@@ -44,6 +44,8 @@
#include <signal.h>
#include "_scm.h"
+#include "scmsigs.h"
+
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
@@ -55,6 +57,11 @@
#define signal ssignal /* Needed for TURBOC V1.0 */
#endif
+#ifdef USE_MIT_PTHREADS
+#undef signal
+#define signal pthread_signal
+#endif
+
/* SIGRETTYPE is the type that signal handlers return. See <signal.h>*/
diff --git a/libguile/scmsigs.h b/libguile/scmsigs.h
index 484b15e9d..261acd62c 100644
--- a/libguile/scmsigs.h
+++ b/libguile/scmsigs.h
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-
+#include "libguile/__scm.h"
#ifdef __STDC__
diff --git a/libguile/sequences.c b/libguile/sequences.c
index 6973f74dc..d58d20040 100644
--- a/libguile/sequences.c
+++ b/libguile/sequences.c
@@ -43,6 +43,7 @@
#include <stdio.h>
#include "_scm.h"
+#include "sequences.h"
diff --git a/libguile/sequences.h b/libguile/sequences.h
index a508daa9b..eeaa6789a 100644
--- a/libguile/sequences.h
+++ b/libguile/sequences.h
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/simpos.c b/libguile/simpos.c
index f04e28cc5..702489510 100644
--- a/libguile/simpos.c
+++ b/libguile/simpos.c
@@ -42,6 +42,13 @@
#include <stdio.h>
#include "_scm.h"
+
+#include "scmsigs.h"
+#include "simpos.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
@@ -76,7 +83,7 @@ scm_system(cmd)
#endif
extern char *getenv();
-SCM_PROC (s_sys_getenv, "%getenv", 1, 0, 0, scm_sys_getenv);
+SCM_PROC (s_sys_getenv, "getenv", 1, 0, 0, scm_sys_getenv);
#ifdef __STDC__
SCM
scm_sys_getenv(SCM nam)
@@ -92,7 +99,7 @@ scm_sys_getenv(nam)
nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0);
val = getenv(SCM_CHARS(nam));
if (!val)
- return SCM_BOOL_F;
+ scm_syserror (s_sys_getenv);
return scm_makfromstr(val, (scm_sizet)strlen(val), 0);
}
diff --git a/libguile/simpos.h b/libguile/simpos.h
index 78cce68a5..929dc6b61 100644
--- a/libguile/simpos.h
+++ b/libguile/simpos.h
@@ -1,7 +1,7 @@
/* classes: h_files */
-#ifndef SSCM_IMPOSH
-#define SSCM_IMPOSH
+#ifndef SIMPOSH
+#define SIMPOSH
/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-
+#include "libguile/__scm.h"
#ifdef __STDC__
@@ -64,4 +64,4 @@ extern void scm_init_simpos ();
-#endif /* SSCM_IMPOSH */
+#endif /* SIMPOSH */
diff --git a/libguile/smob.c b/libguile/smob.c
index 4843d486f..40604af2a 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -42,6 +42,9 @@
#include <stdio.h>
#include "_scm.h"
+
+#include "smob.h"
+
#ifdef HAVE_MALLOC_H
#include <malloc.h>
#endif
diff --git a/libguile/smob.h b/libguile/smob.h
index a35cefc27..cf5712fc7 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -43,39 +43,17 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
-#include "params.h"
+#include "libguile/__scm.h"
-
-
-
typedef struct scm_smobfuns
{
SCM (*mark) SCM_P ((SCM));
scm_sizet (*free) SCM_P ((SCM));
- int (*print) SCM_P ((SCM exp, SCM port, int writing));
+ int (*print) SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
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));
@@ -85,19 +63,16 @@ 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 */
-
-
+/* Everyone who uses smobs needs to print. */
+#include "libguile/ports.h"
+#include "libguile/genio.h"
+/* ... and they all need to GC. */
+#include "libguile/markers.h"
+
+extern long scm_newsmob SCM_P ((scm_smobfuns *smob));
+extern void scm_smob_prehistory SCM_P ((void));
#endif /* SMOBH */
diff --git a/libguile/socket.c b/libguile/socket.c
index 944609714..0ed4a9b71 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -1,15 +1,61 @@
/* "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.
- */
+ * Copyright (C) 1995,1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* Written in 1994 by Aubrey Jaffer.
+ * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
+ * Rewritten by Gary Houston to be a closer interface to the C socket library.
+ */
#include <stdio.h>
-#include <string.h>
#include "_scm.h"
+#include "feature.h"
+
+#include "socket.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
#include <sys/types.h>
#include <sys/socket.h>
#include <sys/un.h>
@@ -23,7 +69,9 @@
int close P ((int fd));
#endif /* STDC_HEADERS */
-SCM_PROC (s_sys_inet_aton, "%inet-aton", 1, 0, 0, scm_sys_inet_aton);
+extern int inet_aton ();
+
+SCM_PROC (s_sys_inet_aton, "inet-aton", 1, 0, 0, scm_sys_inet_aton);
#ifdef __STDC__
SCM
scm_sys_inet_aton (SCM address)
@@ -34,12 +82,13 @@ scm_sys_inet_aton (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;
+ if (inet_aton (SCM_ROCHARS (address), &soka) == 0)
+ scm_syserror (s_sys_inet_aton);
+ return scm_ulong2num (ntohl (soka.s_addr));
}
@@ -121,7 +170,7 @@ scm_inet_makeaddr (net, lna)
* Assumes hostent stream isn't reused.
*/
-SCM_PROC (s_sys_gethost, "%gethost", 0, 1, 0, scm_sys_gethost);
+SCM_PROC (s_sys_gethost, "gethost", 0, 1, 0, scm_sys_gethost);
#ifdef __STDC__
SCM
scm_sys_gethost (SCM name)
@@ -159,7 +208,7 @@ scm_sys_gethost (name)
}
SCM_ALLOW_INTS;
if (!entry)
- return SCM_BOOL_F;
+ scm_syserror (s_sys_gethost);
ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
ve[1] = scm_makfromstrs (-1, entry->h_aliases);
ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
@@ -180,7 +229,7 @@ scm_sys_gethost (name)
}
-SCM_PROC (s_sys_getnet, "%getnet", 0, 1, 0, scm_sys_getnet);
+SCM_PROC (s_sys_getnet, "getnet", 0, 1, 0, scm_sys_getnet);
#ifdef __STDC__
SCM
scm_sys_getnet (SCM name)
@@ -215,7 +264,7 @@ scm_sys_getnet (name)
}
SCM_ALLOW_INTS;
if (!entry)
- return SCM_BOOL_F;
+ scm_syserror (s_sys_getnet);
ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
ve[1] = scm_makfromstrs (-1, entry->n_aliases);
ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
@@ -223,7 +272,7 @@ scm_sys_getnet (name)
return ans;
}
-SCM_PROC (s_sys_getproto, "%getproto", 0, 1, 0, scm_sys_getproto);
+SCM_PROC (s_sys_getproto, "getproto", 0, 1, 0, scm_sys_getproto);
#ifdef __STDC__
SCM
scm_sys_getproto (SCM name)
@@ -258,7 +307,7 @@ scm_sys_getproto (name)
}
SCM_ALLOW_INTS;
if (!entry)
- return SCM_BOOL_F;
+ scm_syserror (s_sys_getproto);
ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
ve[1] = scm_makfromstrs (-1, entry->p_aliases);
ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
@@ -279,11 +328,6 @@ scm_return_entry (entry)
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);
@@ -292,7 +336,7 @@ scm_return_entry (entry)
return ans;
}
-SCM_PROC (s_sys_getserv, "%getserv", 0, 2, 0, scm_sys_getserv);
+SCM_PROC (s_sys_getserv, "getserv", 0, 2, 0, scm_sys_getserv);
#ifdef __STDC__
SCM
scm_sys_getserv (SCM name, SCM proto)
@@ -308,6 +352,8 @@ scm_sys_getserv (name, proto)
{
SCM_DEFER_INTS;
entry = getservent ();
+ if (!entry)
+ scm_syserror (s_sys_getserv);
return scm_return_entry (entry);
}
SCM_ASSERT (SCM_NIMP (proto) && SCM_STRINGP (proto), proto, SCM_ARG2, s_sys_getserv);
@@ -322,6 +368,8 @@ scm_sys_getserv (name, proto)
SCM_DEFER_INTS;
entry = getservbyport (SCM_INUM (name), SCM_CHARS (proto));
}
+ if (!entry)
+ scm_syserror (s_sys_getserv);
return scm_return_entry (entry);
}
diff --git a/libguile/socket.h b/libguile/socket.h
index 28413a228..95b4ea749 100644
--- a/libguile/socket.h
+++ b/libguile/socket.h
@@ -44,13 +44,14 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
#ifdef __STDC__
+extern SCM scm_sys_gethost (SCM name);
extern SCM scm_sys_inet_aton (SCM address);
extern SCM scm_inet_ntoa (SCM inetid);
extern SCM scm_inet_netof (SCM address);
@@ -63,26 +64,10 @@ 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_gethost ();
extern SCM scm_sys_inet_aton ();
extern SCM scm_inet_ntoa ();
extern SCM scm_inet_netof ();
@@ -95,22 +80,6 @@ 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 */
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
new file mode 100644
index 000000000..537302d5f
--- /dev/null
+++ b/libguile/srcprop.c
@@ -0,0 +1,375 @@
+/* Copyright (C) 1995,1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include <stdio.h>
+#include "_scm.h"
+#include "smob.h"
+#include "alist.h"
+#include "debug.h"
+#include "hashtab.h"
+#include "hash.h"
+#include "weaks.h"
+
+#include "srcprop.h"
+
+/* {Source Properties}
+ *
+ * Properties of source list expressions.
+ * Five of these have special meaning and optimized storage:
+ *
+ * filename string The name of the source file.
+ * copy list A copy of the list expression.
+ * line integer The source code line number.
+ * column integer The source code column number.
+ * breakpoint boolean Sets a breakpoint on this form.
+ *
+ * Most properties above can be set by the reader.
+ *
+ */
+
+SCM scm_i_copy;
+static SCM scm_i_breakpoint, scm_i_line, scm_i_column;
+static SCM scm_i_filename;
+
+long scm_tc16_srcprops;
+static scm_srcprops_chunk *srcprops_chunklist = 0;
+static scm_srcprops *srcprops_freelist = 0;
+
+#ifdef __STDC__
+static SCM
+marksrcprops (SCM obj)
+#else
+static SCM
+marksrcprops (obj)
+ SCM obj;
+#endif
+{
+ SCM_SETGC8MARK (obj);
+ scm_gc_mark (SRCPROPFNAME (obj));
+ scm_gc_mark (SRCPROPCOPY (obj));
+ return SRCPROPPLIST (obj);
+}
+
+#ifdef __STDC__
+static scm_sizet
+freesrcprops (SCM obj)
+#else
+static scm_sizet
+freesrcprops (obj)
+ SCM obj;
+#endif
+{
+ *((scm_srcprops **) SCM_CDR (obj)) = srcprops_freelist;
+ srcprops_freelist = (scm_srcprops *) SCM_CDR (obj);
+ return 0; /* srcprops_chunks are not freed until leaving guile */
+}
+
+#ifdef __STDC__
+static int
+prinsrcprops (SCM obj, SCM port, scm_print_state *pstate)
+#else
+static int
+prinsrcprops (obj, port, pstate)
+ SCM obj;
+ SCM port;
+ scm_print_state *pstate;
+#endif
+{
+ int writingp = SCM_WRITINGP (pstate);
+ scm_gen_puts (scm_regular_string, "#<srcprops ", port);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
+ scm_gen_putc ('>', port);
+ return 1;
+}
+
+static scm_smobfuns srcpropssmob =
+{marksrcprops, freesrcprops, prinsrcprops, 0};
+
+#ifdef __STDC__
+SCM
+scm_make_srcprops (int line, int col, SCM filename, SCM copy, SCM plist)
+#else
+SCM
+scm_make_srcprops (line, col, filename, copy, plist)
+ int line;
+ int col;
+ SCM filename;
+ SCM copy;
+ SCM plist;
+#endif
+{
+ register SCM ans;
+ register scm_srcprops *ptr;
+ SCM_DEFER_INTS;
+ if ((ptr = srcprops_freelist) != NULL)
+ srcprops_freelist = *(scm_srcprops **)ptr;
+ else
+ {
+ int i;
+ scm_srcprops_chunk *mem;
+ scm_sizet n = sizeof (scm_srcprops_chunk)
+ + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
+ SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n));
+ SCM_ASSERT (mem, SCM_UNDEFINED, SCM_NALLOC, "srcprops");
+ scm_mallocated += n;
+ mem->next = srcprops_chunklist;
+ srcprops_chunklist = mem;
+ ptr = &mem->srcprops[0];
+ for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i)
+ *(scm_srcprops **)&ptr[i] = &ptr[i + 1];
+ *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0;
+ srcprops_freelist = (scm_srcprops *) &ptr[1];
+ }
+ SCM_NEWCELL (ans);
+ SCM_CAR (ans) = scm_tc16_srcprops;
+ ptr->pos = SRCPROPMAKPOS (line, col);
+ ptr->fname = filename;
+ ptr->copy = copy;
+ ptr->plist = plist;
+ SCM_CDR (ans) = (SCM) ptr;
+ SCM_ALLOW_INTS;
+ return ans;
+}
+
+#ifdef __STDC__
+SCM
+scm_srcprops_to_plist (SCM obj)
+#else
+SCM
+scm_srcprops_to_plist (obj)
+ SCM obj;
+#endif
+{
+ SCM plist = SRCPROPPLIST (obj);
+ if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
+ plist = scm_acons (scm_i_copy, SRCPROPCOPY (obj), plist);
+ if (!SCM_UNBNDP (SRCPROPFNAME (obj)))
+ plist = scm_acons (scm_i_filename, SRCPROPFNAME (obj), plist);
+ plist = scm_acons (scm_i_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist);
+ plist = scm_acons (scm_i_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist);
+ plist = scm_acons (scm_i_breakpoint, SRCPROPBRK (obj), plist);
+ return plist;
+}
+
+SCM_PROC (s_source_properties, "source-properties", 1, 0, 0, scm_source_properties);
+#ifdef __STDC__
+SCM
+scm_source_properties (SCM obj)
+#else
+SCM
+scm_source_properties (obj)
+ SCM obj;
+#endif
+{
+ SCM p;
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOEXP (obj);
+ p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL);
+ if (p != (SCM) NULL && SRCPROPSP (p))
+ return scm_srcprops_to_plist (p);
+ return SCM_EOL;
+}
+
+/* Perhaps this procedure should look through an alist
+ and try to make a srcprops-object...? */
+SCM_PROC (s_set_source_properties_x, "set-source-properties!", 2, 0, 0, scm_set_source_properties_x);
+#ifdef __STDC__
+SCM
+scm_set_source_properties_x (SCM obj, SCM plist)
+#else
+SCM
+scm_set_source_properties_x (obj, plist)
+ SCM obj;
+ SCM plist;
+#endif
+{
+ SCM handle;
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOEXP (obj);
+ handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist);
+ SCM_SETCDR (handle, plist);
+ return plist;
+}
+
+SCM_PROC (s_source_property, "source-property", 2, 0, 0, scm_source_property);
+#ifdef __STDC__
+SCM
+scm_source_property (SCM obj, SCM key)
+#else
+SCM
+scm_source_property (obj, key)
+ SCM obj;
+ SCM key;
+#endif
+{
+ SCM p;
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOEXP (obj);
+ p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
+ if (SCM_IMP (p) || !SRCPROPSP (p))
+ goto plist;
+ if (scm_i_breakpoint == key) p = SRCPROPBRK (p);
+ else if (scm_i_line == key) p = SCM_MAKINUM (SRCPROPLINE (p));
+ else if (scm_i_column == key) p = SCM_MAKINUM (SRCPROPCOL (p));
+ else if (scm_i_filename == key) p = SRCPROPFNAME (p);
+ else if (scm_i_copy == key) p = SRCPROPCOPY (p);
+ else
+ {
+ p = SRCPROPPLIST (p);
+ plist:
+ p = scm_assoc (key, p);
+ return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
+ }
+ return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
+}
+
+SCM_PROC (s_set_source_property_x, "set-source-property!", 3, 0, 0, scm_set_source_property_x);
+#ifdef __STDC__
+SCM
+scm_set_source_property_x (SCM obj, SCM key, SCM datum)
+#else
+SCM
+scm_set_source_property_x (obj, key, datum)
+ SCM obj;
+ SCM key;
+ SCM datum;
+#endif
+{
+ scm_whash_handle h;
+ SCM p;
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOEXP (obj);
+ h = scm_whash_get_handle (scm_source_whash, obj);
+ if (SCM_WHASHFOUNDP (h))
+ p = SCM_WHASHREF (scm_source_whash, h);
+ else
+ {
+ h = scm_whash_create_handle (scm_source_whash, obj);
+ p = SCM_EOL;
+ }
+ if (scm_i_breakpoint == key)
+ if (SCM_FALSEP (datum))
+ CLEARSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
+ ? p
+ : SCM_WHASHSET (scm_source_whash, h,
+ scm_make_srcprops (0, 0, SCM_UNDEFINED,
+ SCM_UNDEFINED, p)));
+ else
+ SETSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
+ ? p
+ : SCM_WHASHSET (scm_source_whash, h,
+ scm_make_srcprops (0, 0, SCM_UNDEFINED,
+ SCM_UNDEFINED, p)));
+ else if (scm_i_line == key)
+ {
+ if (SCM_NIMP (p) && SRCPROPSP (p))
+ SETSRCPROPLINE (p, datum);
+ else
+ SCM_WHASHSET (scm_source_whash, h,
+ scm_make_srcprops (datum, 0, SCM_UNDEFINED, SCM_UNDEFINED, p));
+ }
+ else if (scm_i_column == key)
+ {
+ if (SCM_NIMP (p) && SRCPROPSP (p))
+ SETSRCPROPCOL (p, datum);
+ else
+ SCM_WHASHSET (scm_source_whash, h,
+ scm_make_srcprops (0, datum, SCM_UNDEFINED, SCM_UNDEFINED, p));
+ }
+ else if (scm_i_filename == key)
+ {
+ if (SCM_NIMP (p) && SRCPROPSP (p))
+ SRCPROPFNAME (p) = datum;
+ else
+ SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p));
+ }
+ else if (scm_i_filename == key)
+ {
+ if (SCM_NIMP (p) && SRCPROPSP (p))
+ SRCPROPCOPY (p) = datum;
+ else
+ SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
+ }
+ else
+ SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
+ return SCM_UNSPECIFIED;
+}
+
+#ifdef __STDC__
+void
+scm_init_srcprop (void)
+#else
+void
+scm_init_srcprop ()
+#endif
+{
+ scm_tc16_srcprops = scm_newsmob (&srcpropssmob);
+ scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047));
+
+ scm_i_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED));
+ scm_i_copy = SCM_CAR (scm_sysintern ("copy", SCM_UNDEFINED));
+ scm_i_line = SCM_CAR (scm_sysintern ("line", SCM_UNDEFINED));
+ scm_i_column = SCM_CAR (scm_sysintern ("column", SCM_UNDEFINED));
+ scm_i_breakpoint = SCM_CAR (scm_sysintern ("breakpoint", SCM_UNDEFINED));
+
+ scm_sysintern ("source-whash", scm_source_whash);
+#include "srcprop.x"
+}
+
+void
+scm_finish_srcprop ()
+{
+ register scm_srcprops_chunk *ptr = srcprops_chunklist, *next;
+ while (ptr)
+ {
+ next = ptr->next;
+ free ((char *) ptr);
+ scm_mallocated -= sizeof (scm_srcprops_chunk)
+ + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
+ ptr = next;
+ }
+}
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
new file mode 100644
index 000000000..32f6f810a
--- /dev/null
+++ b/libguile/srcprop.h
@@ -0,0 +1,140 @@
+/* classes: h_files */
+
+#ifndef SRCPROPH
+#define SRCPROPH
+/* Copyright (C) 1995,1996 Mikael Djurfeldt
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ *
+ * The author can be reached at djurfeldt@nada.kth.se
+ * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+ */
+
+
+#include "libguile/__scm.h"
+
+
+
+SCM scm_i_copy;
+
+/* {The old whash table interface}
+ * *fixme* This is a temporary solution until weak hash table access
+ * has been optimized for speed (which is quite necessary, if they are
+ * used for recording of source code positions...)
+ */
+
+#define scm_whash_handle SCM
+
+#define scm_whash_get_handle(whash, key) scm_hash_fn_get_handle (whash, key, scm_ihashq, scm_sloppy_assq, 0)
+#define SCM_WHASHFOUNDP(h) ((h) != SCM_BOOL_F)
+#define SCM_WHASHREF(whash, handle) SCM_CDR (handle)
+#define SCM_WHASHSET(whash, handle, obj) SCM_SETCDR (handle, obj)
+#define scm_whash_create_handle(whash, key) scm_hash_fn_create_handle_x (whash, key, SCM_UNSPECIFIED, scm_ihashq, scm_sloppy_assq, 0)
+#define scm_whash_lookup(whash, obj) scm_hash_fn_ref (whash, obj, SCM_BOOL_F, scm_ihashq, scm_sloppy_assq, 0)
+#define scm_whash_insert(whash, key, obj) \
+{ \
+ register SCM w = (whash); \
+ SCM_WHASHSET (w, scm_whash_create_handle (w, key), obj); \
+} \
+
+
+/* {Source properties}
+ */
+
+extern long scm_tc16_srcprops;
+
+typedef struct scm_srcprops
+{
+ unsigned long pos;
+ SCM fname;
+ SCM copy;
+ SCM plist;
+} scm_srcprops;
+
+#define SRCPROPS_CHUNKSIZE 2047 /* Number of srcprops per chunk */
+typedef struct scm_srcprops_chunk
+{
+ struct scm_srcprops_chunk *next;
+ scm_srcprops srcprops[1];
+} scm_srcprops_chunk;
+
+#define SRCPROPSP(p) (SCM_TYP16 (p) == scm_tc16_srcprops)
+#define SRCPROPBRK(p) ((1L << 16) & SCM_CAR (p) ? SCM_BOOL_T : SCM_BOOL_F)
+#define SRCPROPPOS(p) ((scm_srcprops *) SCM_CDR (p))->pos
+#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
+#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
+#define SRCPROPFNAME(p) ((scm_srcprops *) SCM_CDR (p))->fname
+#define SRCPROPCOPY(p) ((scm_srcprops *) SCM_CDR (p))->copy
+#define SRCPROPPLIST(p) ((scm_srcprops *) SCM_CDR (p))->plist
+#define SETSRCPROPBRK(p) (SCM_CAR (p) = SCM_CAR (p) | (1L << 16))
+#define CLEARSRCPROPBRK(p) (SCM_CAR (p) = SCM_CAR (p) & ~(1L << 16))
+#define SRCPROPMAKPOS(l,c) (((l) << 12) + (c))
+#define SETSRCPROPPOS(p,l,c) (SRCPROPPOS (p) = SRCPROPMAKPOS (l, c))
+#define SETSRCPROPLINE(p,l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
+#define SETSRCPROPCOL(p,c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
+
+#define SRCBRKP(x) (SCM_NIMP (t.arg1 = scm_whash_lookup (scm_source_whash, (x)))\
+ && SRCPROPSP (t.arg1)\
+ && (1L << 16) & SCM_CAR (t.arg1))
+
+#define PROCTRACEP(x) SCM_NFALSEP (scm_procedure_property (x, scm_i_trace))
+
+
+
+#ifdef __STDC__
+extern SCM scm_srcprops_to_plist (SCM obj);
+extern SCM scm_make_srcprops (int line, int col, SCM fname, SCM copy, SCM plist);
+extern SCM scm_source_property (SCM obj, SCM key);
+extern SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum);
+extern SCM scm_source_properties (SCM obj);
+extern SCM scm_set_source_properties_x (SCM obj, SCM props);
+extern void scm_finish_srcprop (void);
+extern void scm_init_srcprop (void);
+#else
+extern SCM scm_srcprops_to_plist ();
+extern SCM scm_make_srcprops ();
+extern SCM scm_source_property ();
+extern SCM scm_set_source_property_x ();
+extern SCM scm_source_properties ();
+extern SCM scm_set_source_properties_x ();
+extern void scm_finish_srcprop ();
+extern void scm_init_srcprop ();
+#endif
+
+#endif /* SRCPROPH */
diff --git a/libguile/stackchk.c b/libguile/stackchk.c
index 53a7556be..5d08ff391 100644
--- a/libguile/stackchk.c
+++ b/libguile/stackchk.c
@@ -42,20 +42,26 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "stackchk.h"
/* {Stack Checking}
*/
-#ifdef SCM_STACK_CHECK
-int scm_check_stack_p;
+#ifdef STACK_CHECKING
+int scm_stack_checking_enabled_p;
void
scm_report_stack_overflow ()
{
- scm_check_stack_p = 0;
- scm_wta (SCM_UNDEFINED, (char *) STACK_SCM_OVSCM_FLOW, NULL);
+ scm_stack_checking_enabled_p = 0;
+ scm_error (scm_stack_overflow_key,
+ NULL,
+ "Stack overflow",
+ SCM_BOOL_F,
+ SCM_BOOL_F);
}
#endif
@@ -104,9 +110,5 @@ 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
index eb3c436a2..d30fdde23 100644
--- a/libguile/stackchk.h
+++ b/libguile/stackchk.h
@@ -43,37 +43,54 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+#include "libguile/continuations.h"
+#ifdef DEBUG_EXTENSIONS
+#include "libguile/debug.h"
+#endif
-#ifdef SCM_STACK_LIMIT
-# define SCM_STACK_CHECK
+/* With debug extensions we have the possibility to use the debug options
+ * to disable stack checking.
+ */
+#ifdef DEBUG_EXTENSIONS
+#define SCM_STACK_CHECKING_P SCM_STACK_LIMIT
+#else
+/* *fixme* This option should be settable also without debug extensions. */
+#define SCM_STACK_LIMIT 100000
+#define SCM_STACK_CHECKING_P 1
+#endif
+
+#ifdef STACK_CHECKING
# ifdef SCM_STACK_GROWS_UP
-# define SCM_STACK_OVERFLOW_P(s) (s - SCM_BASE (rootcont) > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM))
+# define SCM_STACK_OVERFLOW_P(s)\
+ (s - SCM_BASE (scm_rootcont) > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM))
# else
-# define SCM_STACK_OVERFLOW_P(s) (SCM_BASE (rootcont) - s > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM))
+# define SCM_STACK_OVERFLOW_P(s)\
+ (SCM_BASE (scm_rootcont) - s > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM))
# endif
# define SCM_CHECK_STACK\
{\
SCM_STACKITEM stack;\
- if (SCM_STACK_OVERFLOW_P (&stack) && scm_check_stack_p)\
+ if (SCM_STACK_OVERFLOW_P (&stack) && scm_stack_checking_enabled_p)\
scm_report_stack_overflow ();\
}
#else
# define SCM_CHECK_STACK /**/
-#endif /* def SCM_STACK_LIMIT */
-
+#endif /* STACK_CHECKING */
-extern int scm_check_stack_p;
+extern int scm_stack_checking_enabled_p;
#ifdef __STDC__
+extern void scm_report_stack_overflow (void);
extern long scm_stack_size (SCM_STACKITEM *start);
extern void scm_stack_report (void);
extern void scm_init_stackchk (void);
#else /* STDC */
+extern void scm_report_stack_overflow ();
extern long scm_stack_size ();
extern void scm_stack_report ();
extern void scm_init_stackchk ();
diff --git a/libguile/stime.c b/libguile/stime.c
index 77ead9a7a..efc9d172f 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -42,6 +42,9 @@
#include <stdio.h>
#include "_scm.h"
+
+#include "stime.h"
+
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
@@ -106,13 +109,8 @@
#endif
#ifdef HAVE_TIMES
-#ifdef __STDC__
-static
-long mytime(void)
-#else
static
long mytime()
-#endif
{
struct tms time_buffer;
times(&time_buffer);
@@ -130,15 +128,12 @@ long mytime()
#ifdef HAVE_FTIME
+extern int ftime (struct timeb *);
+
struct timeb scm_your_base = {0};
SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
-#ifdef __STDC__
-SCM
-scm_get_internal_real_time(void)
-#else
SCM
scm_get_internal_real_time()
-#endif
{
struct timeb time_buffer;
long tmp;
@@ -155,13 +150,8 @@ scm_get_internal_real_time()
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);
}
@@ -172,25 +162,15 @@ scm_get_internal_real_time()
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;
@@ -198,27 +178,17 @@ scm_current_time()
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));
diff --git a/libguile/stime.h b/libguile/stime.h
index c492d40fe..54a093bc3 100644
--- a/libguile/stime.h
+++ b/libguile/stime.h
@@ -44,32 +44,13 @@
*/
-#include "__scm.h"
+#include "libguile/__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 */
-
-
-
-
-
+extern SCM scm_get_internal_real_time SCM_P ((void));
+extern SCM scm_get_internal_run_time SCM_P ((void));
+extern SCM scm_current_time SCM_P ((void));
+extern long scm_time_in_msec SCM_P ((long x));
+extern void scm_init_stime SCM_P ((void));
#endif /* TIMEH */
diff --git a/libguile/strerror.c b/libguile/strerror.c
new file mode 100644
index 000000000..4723d04e8
--- /dev/null
+++ b/libguile/strerror.c
@@ -0,0 +1,32 @@
+/* Turning errno values into English error messages.
+ Copyright (C) 1985, 86, 87, 88, 93, 94, 95 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+GNU Emacs is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with GNU Emacs; see the file COPYING. If not, write to
+the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA. */
+
+
+char *
+strerror (errnum)
+ int errnum;
+{
+ extern char *sys_errlist[];
+ extern int sys_nerr;
+
+ if (errnum >= 0 && errnum < sys_nerr)
+ return sys_errlist[errnum];
+ return (char *) "Unknown error";
+}
diff --git a/libguile/strings.c b/libguile/strings.c
index ea96e8c30..5cab941fc 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -42,7 +42,9 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "strings.h"
/* {Strings}
@@ -232,11 +234,11 @@ scm_makfromstr (src, len, slots)
#ifdef __STDC__
SCM
-scm_makfrom0str (char *src)
+scm_makfrom0str (const char *src)
#else
SCM
scm_makfrom0str (src)
- char *src;
+ const char *src;
#endif
{
if (!src) return SCM_BOOL_F;
@@ -245,11 +247,11 @@ scm_makfrom0str (src)
#ifdef __STDC__
SCM
-scm_makfrom0str_opt (char *src)
+scm_makfrom0str_opt (const char *src)
#else
SCM
scm_makfrom0str_opt (src)
- char *src;
+ const char *src;
#endif
{
return scm_makfrom0str (src);
diff --git a/libguile/strings.h b/libguile/strings.h
index 6615e2330..e122d1af9 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -44,7 +44,11 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
@@ -61,8 +65,8 @@ 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_makfrom0str (const char *src);
+extern SCM scm_makfrom0str_opt (const 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);
diff --git a/libguile/strop.c b/libguile/strop.c
index 366d249da..bfcf5f498 100644
--- a/libguile/strop.c
+++ b/libguile/strop.c
@@ -20,7 +20,9 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "strop.h"
#ifdef __STDC__
@@ -198,7 +200,8 @@ scm_substring_move_left_x (str1, start1, args)
{
SCM end1, str2, start2;
long i, j, e;
- SCM_ASSERT (3==scm_ilength (args), args, SCM_WNA, s_substring_move_left_x);
+ SCM_ASSERT (3==scm_ilength (args), scm_makfrom0str (s_substring_move_left_x),
+ SCM_WNA, NULL);
end1 = SCM_CAR (args); args = SCM_CDR (args);
str2 = SCM_CAR (args); args = SCM_CDR (args);
start2 = SCM_CAR (args);
@@ -231,7 +234,8 @@ scm_substring_move_right_x (str1, start1, args)
{
SCM end1, str2, start2;
long i, j, e;
- SCM_ASSERT (3==scm_ilength (args), args, SCM_WNA, s_substring_move_right_x);
+ SCM_ASSERT (3==scm_ilength (args),
+ scm_makfrom0str (s_substring_move_right_x), SCM_WNA, NULL);
end1 = SCM_CAR (args); args = SCM_CDR (args);
str2 = SCM_CAR (args); args = SCM_CDR (args);
start2 = SCM_CAR (args);
@@ -265,7 +269,8 @@ scm_substring_fill_x (str, start, args)
SCM end, fill;
long i, e;
char c;
- SCM_ASSERT (2==scm_ilength (args), args, SCM_WNA, s_substring_fill_x);
+ SCM_ASSERT (2==scm_ilength (args), scm_makfrom0str (s_substring_fill_x),
+ SCM_WNA, NULL);
end = SCM_CAR (args); args = SCM_CDR (args);
fill = SCM_CAR (args);
SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_substring_fill_x);
diff --git a/libguile/strop.h b/libguile/strop.h
index d2b9a9c00..821e97b1c 100644
--- a/libguile/strop.h
+++ b/libguile/strop.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/strorder.c b/libguile/strorder.c
index 5e1a15a26..8339a893e 100644
--- a/libguile/strorder.c
+++ b/libguile/strorder.c
@@ -42,7 +42,9 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "strorder.h"
SCM_PROC1 (s_string_equal_p, "string=?", scm_tc7_rpsubr, scm_string_equal_p);
diff --git a/libguile/strorder.h b/libguile/strorder.h
index ebc4a8de8..90a7f586e 100644
--- a/libguile/strorder.h
+++ b/libguile/strorder.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/strports.c b/libguile/strports.c
index 1ba808a51..5f09a208e 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -42,6 +42,14 @@
#include <stdio.h>
#include "_scm.h"
+#include "unif.h"
+#include "eval.h"
+
+#include "strports.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
@@ -214,7 +222,7 @@ scm_strprint_obj (obj)
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_prin1 (obj, port, 1);
{
SCM answer;
SCM_DEFER_INTS;
diff --git a/libguile/strports.h b/libguile/strports.h
index 2eb01961e..e8ba90ff4 100644
--- a/libguile/strports.h
+++ b/libguile/strports.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
extern scm_ptobfuns scm_stptob;
diff --git a/libguile/struct.c b/libguile/struct.c
index 265c7d4fd..91dee41c8 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -42,6 +42,13 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+
+#include "struct.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
@@ -91,12 +98,22 @@ scm_make_struct_layout (fields)
switch (field_desc[x + 1])
{
case 'w':
- SCM_ASSERT ((field_desc[x] != 's'), SCM_MAKICHR (field_desc[x + 1]),
+ SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
"self fields not writable", s_struct_make_layout);
case 'r':
case 'o':
break;
+ case 'R':
+ case 'W':
+ case 'O':
+ SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
+ "self fields not allowed in tail array",
+ s_struct_make_layout);
+ SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]),
+ "tail array field must be last field in layout",
+ s_struct_make_layout);
+ break;
default:
SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
}
@@ -119,34 +136,50 @@ scm_make_struct_layout (fields)
#ifdef __STDC__
static void
-init_struct (SCM handle, SCM tail_elts, SCM inits)
+init_struct (SCM handle, int tail_elts, SCM inits)
#else
static void
init_struct (handle, tail_elts, inits)
SCM handle;
- SCM tail_elts;
+ int tail_elts;
SCM inits;
#endif
{
SCM layout;
SCM * data;
unsigned char * fields_desc;
+ unsigned char prot;
int n_fields;
SCM * mem;
-
+ int tailp = 0;
+
layout = SCM_STRUCT_LAYOUT (handle);
data = SCM_STRUCT_DATA (handle);
- fields_desc = (unsigned char *)SCM_CHARS (layout);
+ fields_desc = (unsigned char *) SCM_CHARS (layout) - 2;
n_fields = SCM_LENGTH (layout) / 2;
mem = SCM_STRUCT_DATA (handle);
while (n_fields)
{
+ if (!tailp)
+ {
+ fields_desc += 2;
+ prot = fields_desc[1];
+ if (SCM_LAYOUT_TAILP (prot))
+ {
+ tailp = 1;
+ prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
+ *mem++ = tail_elts;
+ n_fields += tail_elts - 1;
+ if (n_fields == 0)
+ break;
+ }
+ }
+
switch (*fields_desc)
{
#if 0
case 'i':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*mem = 0;
else
{
@@ -157,8 +190,7 @@ init_struct (handle, tail_elts, inits)
#endif
case 'u':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*mem = 0;
else
{
@@ -168,8 +200,7 @@ init_struct (handle, tail_elts, inits)
break;
case 'p':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || (inits == SCM_EOL))
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*mem = SCM_EOL;
else
{
@@ -181,8 +212,7 @@ init_struct (handle, tail_elts, inits)
#if 0
case 'd':
- if ( ((fields_desc[1] != 'r') && (fields_desc[1] != 'w'))
- || ((inits == SCM_EOL) || !SCM_NUMBERP (SCM_CAR (inits))))
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
*((double *)mem) = 0.0;
else
{
@@ -198,7 +228,6 @@ init_struct (handle, tail_elts, inits)
break;
}
- fields_desc += 2;
n_fields--;
mem++;
}
@@ -288,12 +317,17 @@ scm_make_struct (vtable, tail_array_size, init)
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;
+ data = (SCM*)scm_must_malloc (sizeof (SCM) * (scm_struct_n_extra_words
+ + basic_size
+ + tail_elts),
+ "structure");
+ data += scm_struct_n_extra_words;
+ data[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words
+ + basic_size
+ + tail_elts);
+ data[scm_struct_i_tag] = struct_num++;
SCM_SETCDR (handle, data);
- SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + 1);
+ SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
init_struct (handle, tail_elts, init);
SCM_ALLOW_INTS;
return handle;
@@ -333,12 +367,17 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init)
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;
+ data = (SCM *) scm_must_malloc (sizeof (SCM) * (scm_struct_n_extra_words
+ + basic_size
+ + tail_elts),
+ "structure");
+ data += scm_struct_n_extra_words;
+ data[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words
+ + basic_size
+ + tail_elts);
+ data[scm_struct_i_tag] = struct_num++;
SCM_SETCDR (handle, data);
- SCM_SETCAR (handle, ((SCM)data) + 1);
+ SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
SCM_STRUCT_LAYOUT (handle) = layout;
init_struct (handle, tail_elts, scm_cons (layout, init));
SCM_ALLOW_INTS;
@@ -359,7 +398,7 @@ scm_struct_ref (handle, pos)
SCM pos;
#endif
{
- SCM answer;
+ SCM answer = SCM_UNDEFINED;
SCM * data;
SCM layout;
int p;
@@ -377,22 +416,30 @@ scm_struct_ref (handle, pos)
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);
+ n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
+
+ 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);
- }
- }
+ if (p * 2 < SCM_LENGTH (layout))
+ {
+ unsigned char ref;
+ field_type = fields_desc[p * 2];
+ ref = fields_desc[p * 2 + 1];
+ if ((ref != 'r') && (ref != 'w'))
+ {
+ if ((ref == 'R') || (ref == 'W'))
+ field_type = 'u';
+ else
+ SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
+ }
+ }
+ else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
+ field_type = fields_desc[SCM_LENGTH (layout) - 2];
+ else
+ {
+ SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
+ }
+
switch (field_type)
{
case 'u':
@@ -454,17 +501,25 @@ scm_struct_set_x (handle, pos, val)
p = SCM_INUM (pos);
fields_desc = (unsigned char *)SCM_CHARS (layout);
- n_fields = SCM_LENGTH (layout) / 2;
+ n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
- SCM_ASSERT (p <= n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
+ 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);
- }
+ if (p * 2 < SCM_LENGTH (layout))
+ {
+ unsigned char set_x;
+ field_type = fields_desc[p * 2];
+ set_x = fields_desc [p * 2 + 1];
+ if (set_x != 'w')
+ SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
+ }
+ else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
+ field_type = fields_desc[SCM_LENGTH (layout) - 2];
+ else
+ {
+ SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
+ }
+
switch (field_type)
{
case 'u':
diff --git a/libguile/struct.h b/libguile/struct.h
index b444e282b..a8bff944c 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -44,10 +44,13 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
+/* Number of words with negative index */
+#define scm_struct_n_extra_words 2
+
/* 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.. */
@@ -62,6 +65,8 @@
#define SCM_STRUCT_VTABLE_DATA(X) ((SCM *)(SCM_CAR(X) - 1))
#define SCM_STRUCT_LAYOUT(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_layout])
#define SCM_STRUCT_VTABLE(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_vtable])
+/* Efficiency is important in the following macro, since it's used in GC */
+#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
diff --git a/libguile/symbols.c b/libguile/symbols.c
index 4a6dd6065..30f7ed4f8 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -42,6 +42,17 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "eval.h"
+#include "variable.h"
+#include "alist.h"
+#include "mbstrings.h"
+
+#include "symbols.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
@@ -72,7 +83,7 @@ scm_strhash (str, len, n)
scm_sizet i = 5;
unsigned long h = 264 % n;
while (i--)
- h = ((h << 8) + ((unsigned) (scm_downcase[str[h % len]]))) % n;
+ h = ((h << 8) + ((unsigned) (scm_downcase (str[h % len])))) % n;
return h;
}
else
@@ -80,7 +91,7 @@ scm_strhash (str, len, n)
scm_sizet i = len;
unsigned long h = 0;
while (i)
- h = ((h << 8) + ((unsigned) (scm_downcase[str[--i]]))) % n;
+ h = ((h << 8) + ((unsigned) (scm_downcase (str[--i])))) % n;
return h;
}
}
@@ -209,6 +220,28 @@ scm_sym2ovcell (sym, obarray)
return SCM_UNSPECIFIED; /* not reached */
}
+/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
+
+ OBARRAY should be a vector of lists, indexed by the name's hash
+ value, modulo OBARRAY's length. Each list has the form
+ ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
+ value associated with that symbol (in the current module? in the
+ system module?)
+
+ To "intern" a symbol means: if OBARRAY already contains a symbol by
+ that name, return its (SYMBOL . VALUE) pair; otherwise, create a
+ new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
+ appropriate list of the OBARRAY, and return the pair.
+
+ If softness is non-zero, don't create a symbol if it isn't already
+ in OBARRAY; instead, just return #f.
+
+ If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
+ return (SYMBOL . SCM_UNDEFINED).
+
+ If OBARRAY is scm_symhash, and that doesn't contain the symbol,
+ check scm_weak_symhash instead. */
+
#ifdef __STDC__
SCM
scm_intern_obarray_soft (char *name, scm_sizet len, SCM obarray, int softness)
@@ -240,8 +273,12 @@ scm_intern_obarray_soft (name, len, obarray, softness)
scm_hash = scm_strhash (tmp, i, SCM_LENGTH(obarray));
+ /* softness == -1 used to mean that it was known that the symbol
+ wasn't already in the obarray. I don't think there are any
+ callers that use that case any more, but just in case...
+ -- JimB, Oct 1996 */
if (softness == -1)
- goto mustintern_symbol;
+ abort ();
retry_new_obarray:
for (lsym = SCM_VELTS (obarray)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
@@ -276,12 +313,12 @@ scm_intern_obarray_soft (name, len, obarray, softness)
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_MULTI_BYTE_STRINGP (lsym) = SCM_BOOL_F;
SCM_SYMBOL_HASH (lsym) = scm_hash;
+ SCM_SYMBOL_PROPS (lsym) = SCM_EOL;
if (obarray == SCM_BOOL_F)
{
SCM answer;
@@ -351,6 +388,8 @@ scm_intern0 (name)
}
+/* Intern the symbol named NAME in scm_symhash, and give it the value VAL.
+ NAME is null-terminated. */
#ifdef __STDC__
SCM
scm_sysintern (char *name, SCM val)
@@ -435,9 +474,9 @@ scm_string_to_symbol(s)
if (SCM_TYP7 (answer) == scm_tc7_msymbol)
{
if (SCM_REGULAR_STRINGP (s))
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_F;
+ SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
else
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_T;
+ SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
}
return answer;
}
@@ -477,9 +516,9 @@ scm_string_to_obarray_symbol(o, s, softp)
if (SCM_TYP7 (s) == scm_tc7_msymbol)
{
if (SCM_REGULAR_STRINGP (s))
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_F;
+ SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
else
- SCM_SYMBOL_MULTI_BYTE_SCM_STRINGP (answer) = SCM_BOOL_T;
+ SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
}
return answer;
}
@@ -667,7 +706,7 @@ msymbolize (s)
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_SYMBOL_MULTI_BYTE_STRINGP (s) = SCM_BOOL_F;
SCM_CDR (string) = SCM_EOL;
SCM_CAR (string) = SCM_EOL;
}
diff --git a/libguile/symbols.h b/libguile/symbols.h
index b1486ce7a..1936bd7c5 100644
--- a/libguile/symbols.h
+++ b/libguile/symbols.h
@@ -44,15 +44,40 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
extern int scm_symhash_dim;
+/* SCM_LENGTH(SYM) is the length of SYM's name in characters, and
+ SCM_CHARS(SYM) is the address of the first character of SYM's name.
+
+ Beyond that, there are two kinds of symbols: ssymbols and msymbols,
+ distinguished by the 'S' bit in the type.
+
+ Ssymbols are just uniquified strings. They have a length, chars,
+ and that's it. They use the scm_tc7_ssymbol tag (S bit clear).
+
+ Msymbols are symbols with extra slots. These slots hold a property
+ list and a function value (for Emacs Lisp compatibility), a hash
+ code, and a flag to indicate whether their name contains multibyte
+ characters. They use the scm_tc7_msymbol tag.
+
+ We'd like SCM_CHARS to work on msymbols just as it does on
+ ssymbols, so we'll have it point to the symbol's name as usual, and
+ store a pointer to the slots just before the name in memory. Thus,
+ you have to do some casting and pointer arithmetic to find the
+ slots; see the SCM_SLOTS macro.
+
+ In practice, the slots always live just before the pointer to them.
+ So why not ditch the pointer, and use negative indices to refer to
+ the slots? That's a good question; ask the author. I think it was
+ the cognac. */
+
#define SCM_SYMBOLP(x) (SCM_TYP7S(x)==scm_tc7_ssymbol)
#define SCM_LENGTH(x) (((unsigned long)SCM_CAR(x))>>8)
#define SCM_LENGTH_MAX (0xffffffL)
-#define SCM_SETLENGTH(x, v, t) SCM_CAR(x) = ((v)<<8)+(t)
+#define SCM_SETLENGTH(x, v, t) SCM_SETCAR((x), ((v)<<8)+(t))
#define SCM_SETCHARS SCM_SETCDR
#define SCM_CHARS(x) ((char *)(SCM_CDR(x)))
#define SCM_UCHARS(x) ((unsigned char *)(SCM_CDR(x)))
@@ -61,7 +86,7 @@ extern int scm_symhash_dim;
#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_SYMBOL_MULTI_BYTE_STRINGP(X) (*(unsigned long*)(&SCM_SLOTS(X)[3]))
#define SCM_ROSTRINGP(x) ((SCM_TYP7SD(x)==scm_tc7_string) || (SCM_TYP7S(x) == scm_tc7_ssymbol))
#define SCM_ROCHARS(x) ((SCM_TYP7(x) == scm_tc7_substring) \
diff --git a/libguile/tag.c b/libguile/tag.c
index a305d70b2..66023cf23 100644
--- a/libguile/tag.c
+++ b/libguile/tag.c
@@ -41,7 +41,10 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "struct.h"
+#include "tag.h"
SCM_CONST_LONG (scm_utag_immediate_integer, "utag_immediate_integer", 0);
diff --git a/libguile/tag.h b/libguile/tag.h
index a7d1ab761..7ee1ba4c0 100644
--- a/libguile/tag.h
+++ b/libguile/tag.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
diff --git a/libguile/tags.h b/libguile/tags.h
index 1469a90f6..e30798f43 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -3,17 +3,17 @@
#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.
@@ -40,11 +40,11 @@
*
* If you write modifications of your own for GUILE, it is your choice
* whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
+ * If you do not wish that, delete this exception notice.
*/
-/** This file defines the format of SCM values and cons pairs.
+/** This file defines the format of SCM values and cons pairs.
** It is here that tag bits are assigned for various purposes.
**/
@@ -80,37 +80,37 @@ typedef long SCM;
*
* 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-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).
+ * 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.
+ * 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!
+ * this (or any other detail of tagging) seem arbitrary? Try changing it!
* (Not always impossible but it is fair to say that many details of tags
- * are mutually dependent).
- */
+ * 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.
+ * 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).
@@ -134,7 +134,7 @@ typedef long SCM;
* 100 --- IMMEDIATES
*
* Looking at the seven final bits of an immediate:
- *
+ *
* 0000-100 short instruction
* 0001-100 short instruction
* 0010-100 short instruction
@@ -152,7 +152,7 @@ typedef long SCM;
* 1110-100 immediate characters
* 1111-100 ilocs
*
- * Some of the 0110100 immediates are long instructions (they dispatch
+ * 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.
@@ -196,8 +196,13 @@ typedef long SCM;
*
* 101 & 111 --- tc7_ types
*
- * tc7_tags are 7 bit tags ending in 1x1. These tags occur
- * only in the CAR of heap cells.
+ * tc7_tags are 7 bit tags ending in 1x1. These tags
+ * occur only in the CAR of heap cells, and have the
+ * handy property that all bits of the CAR above the
+ * bottom eight can be used to store a length, thus
+ * saving a word in the body itself. Thus, we use them
+ * for strings, symbols, and vectors (among other
+ * things).
*
* SCM_LENGTH returns the bits in "length" (see the diagram).
* SCM_CHARS returns the data cast to "char *"
@@ -208,25 +213,36 @@ typedef long SCM;
* that applies to a particular type, see the header file
* for that type.
*
+ * Sometimes we choose the bottom seven bits carefully,
+ * so that the 4- and 1-valued bits (called the D and S
+ * bits) can be masked off to reveal a common type.
+ *
* TYP7S(X) returns TYP7, but masking out the option bit S.
* TYP7D(X) returns TYP7, but masking out the option bit D.
* TYP7SD(X) masks out both option bits.
*
+ * For example, all strings have 001 in the 'xxx' bits in
+ * the diagram above, the D bit says whether it's a
+ * substring, and the S bit says whether it's a multibyte
+ * character string.
+ *
* for example:
* D S
- * scm_tc7_string = Gxxx0101
- * scm_tc7_mb_string = Gxxx0111
- * scm_tc7_substring = Gxxx1101
- * scm_tc7_mb_substring = Gxxx1111
+ * scm_tc7_string = G0010101
+ * scm_tc7_mb_string = G0010111
+ * scm_tc7_substring = G0011101
+ * scm_tc7_mb_substring = G0011111
+ *
+ * TYP7DS turns all string tags into tc7_string; thus,
+ * testing TYP7DS against tc7_string is a quick way to
+ * test for any kind of string.
*
- * TYP7S turns tc7_mb_string into tc7_string and
+ * 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
+ * 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:
*
@@ -237,8 +253,7 @@ typedef long SCM;
* 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).
- *
- */
+ * */
@@ -249,7 +264,7 @@ typedef long SCM;
* 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.
+ * 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
@@ -272,7 +287,7 @@ typedef long SCM;
#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.
+/* See numbers.h for macros relating to immediate integers.
*/
#define SCM_ITAG3(x) (7 & (int)x)
@@ -400,14 +415,14 @@ typedef long SCM;
#define scm_tc_dblc (scm_tc16_flo|SCM_REAL_PART|SCM_IMAG_PART)
-/* Smob types 2 and 3:
+/* Smob types 2 and 3:
*/
#define scm_tc16_bigpos 0x027f
#define scm_tc16_bigneg 0x037f
-/* {Immediate Values}
+/* {Immediate Values}
*/
enum scm_tags
@@ -431,12 +446,12 @@ enum scm_tags
/* 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_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM(n)])
#define SCM_MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L)
#define SCM_MAKISYM(n) (((n)<<9)+0x74L)
#define SCM_MAKIFLAG(n) (((n)<<9)+0x174L)
-/* This table must agree with the declarations
+/* This table must agree with the declarations
* in repl.c: {Names of immediate symbols}.
*
* These are used only in eval but their values
@@ -464,7 +479,7 @@ enum scm_tags
#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_EOL SCM_MAKIFLAG(20)
#define SCM_UNSPECIFIED SCM_MAKIFLAG(21)
@@ -476,7 +491,7 @@ enum scm_tags
*/
-/* For cons pairs with immediate values in the CAR
+/* For cons pairs with immediate values in the CAR
*/
#define scm_tcs_cons_imcar 2:case 4:case 6:case 10:\
@@ -521,12 +536,4 @@ enum scm_tags
#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
index a84d7e92e..195e3f74a 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -42,41 +42,55 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "smob.h"
+#include "alist.h"
+#include "eval.h"
+#include "dynwind.h"
+#ifdef DEBUG_EXTENSIONS
+#include "debug.h"
+#endif
+#include "continuations.h"
+#include "stackchk.h"
-
-
+#include "throw.h"
+
/* {Catch and Throw}
*/
static int scm_tc16_jmpbuffer;
-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
+#ifndef DEBUG_EXTENSIONS
#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
#define SETJBJMPBUF SCM_SETCDR
+#else
+#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) )
+#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
+#define SCM_SETJBDFRAME(O,X) SCM_CAR(SCM_CDR (O)) = (SCM)(X)
+#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
+
+static scm_sizet freejb SCM_P ((SCM jbsmob));
+
+static scm_sizet
+freejb (jbsmob)
+ SCM jbsmob;
+{
+ scm_must_free ((char *) SCM_CDR (jbsmob));
+ return sizeof (scm_cell);
+}
#endif
-#ifdef __STDC__
+static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
-printjb (SCM exp, SCM port, int writing)
-#else
-static int
-printjb (exp, port, writing)
+printjb (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
-#endif
+ scm_print_state *pstate;
{
scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port);
scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
@@ -85,35 +99,37 @@ printjb (exp, port, writing)
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)
+static scm_smobfuns jbsmob = {
+ scm_mark0,
+#ifdef DEBUG_EXTENSIONS
+ freejb,
#else
+ scm_free0,
+#endif
+ printjb,
+ 0
+};
+
+static SCM make_jmpbuf SCM_P ((void));
static SCM
make_jmpbuf ()
-#endif
{
SCM answer;
SCM_NEWCELL (answer);
+ SCM_REDEFER_INTS;
+ {
#ifdef DEBUG_EXTENSIONS
- SCM_NEWCELL (SCM_CDR (answer));
+ char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
+ SCM_SETCDR (answer, (SCM) mem);
#endif
- SCM_DEFER_INTS;
- {
SCM_CAR(answer) = scm_tc16_jmpbuffer;
SETJBJMPBUF(answer, (jmp_buf *)0);
DEACTIVATEJB(answer);
}
- SCM_ALLOW_INTS;
+ SCM_REALLOW_INTS;
return answer;
}
-
struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
{
jmp_buf buf; /* must be first */
@@ -121,40 +137,37 @@ struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
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_catch_apply (tag, proc, a1, args, handler)
SCM tag;
- SCM thunk;
+ SCM proc;
+ SCM a1;
+ SCM args;
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);
+ SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
#endif
if (setjmp (jbr.buf))
{
SCM throw_tag;
SCM throw_args;
- SCM_DEFER_INTS;
+#ifdef STACK_CHECKING
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+#endif
+ SCM_REDEFER_INTS;
DEACTIVATEJB (jmpbuf);
scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_ALLOW_INTS;
+ SCM_REALLOW_INTS;
throw_args = jbr.retval;
throw_tag = jbr.throw_tag;
jbr.throw_tag = SCM_EOL;
@@ -164,29 +177,81 @@ scm_catch (tag, thunk, handler)
else
{
ACTIVATEJB (jmpbuf);
- answer = scm_apply (thunk,
- ((tag == SCM_BOOL_F) ? scm_cons (jmpbuf, SCM_EOL) : SCM_EOL),
- SCM_EOL);
- SCM_DEFER_INTS;
+ if (tag == SCM_BOOL_F)
+ answer = scm_apply (proc,
+ SCM_NULLP (a1)
+ ? scm_cons (jmpbuf, SCM_EOL)
+ : scm_cons2 (jmpbuf, a1, args),
+ SCM_EOL);
+ else
+ answer = scm_apply (proc, a1, args);
+ SCM_REDEFER_INTS;
DEACTIVATEJB (jmpbuf);
scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_ALLOW_INTS;
+ SCM_REALLOW_INTS;
}
return answer;
}
+SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
+SCM
+scm_catch (tag, thunk, handler)
+ SCM tag;
+ SCM thunk;
+ SCM handler;
+{
+ SCM_ASSERT ((tag == SCM_BOOL_F)
+ || (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
+ || (tag == SCM_BOOL_T),
+ tag, SCM_ARG1, s_catch);
+ return scm_catch_apply (tag, thunk, SCM_EOL, SCM_EOL, handler);
+}
+
+SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch);
+SCM
+scm_lazy_catch (tag, thunk, handler)
+ SCM tag;
+ SCM thunk;
+ SCM handler;
+{
+ SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag))
+ || (tag == SCM_BOOL_T),
+ tag, SCM_ARG1, s_lazy_catch);
+ scm_dynwinds = scm_acons (tag, handler, scm_dynwinds);
+ return scm_apply (thunk, SCM_EOL, SCM_EOL);
+}
+
+/* The user has thrown to an uncaught key --- print a message and die.
+ 1) If the user wants something different, they can use (catch #t
+ ...) to do what they like.
+ 2) Outside the context of a read-eval-print loop, there isn't
+ anything else good to do; libguile should not assume the existence
+ of a read-eval-print loop.
+ 3) Given that we shouldn't do anything complex, it's much more
+ robust to do it in C code. */
+static SCM uncaught_throw SCM_P ((SCM key, SCM args));
+static SCM
+uncaught_throw (key, args)
+ SCM key;
+ SCM args;
+{
+ SCM p = scm_def_errp;
+ scm_gen_puts (scm_regular_string, "guile: uncaught throw to ", p);
+ scm_prin1 (key, p, 0);
+ scm_gen_puts (scm_regular_string, ": ", p);
+ scm_prin1 (args, p, 1);
+ scm_gen_putc ('\n', p);
+
+ exit (2);
+}
+
static char s_throw[];
-#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;
@@ -206,27 +271,39 @@ scm_ithrow (key, args, noreturn)
else
{
SCM dynpair;
- SCM hook;
+ SCM winds;
if (noreturn)
{
- SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, s_throw);
+ 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);
+ /* Search the wind list for an appropriate catch.
+ "Waiter, please bring us the wind list." */
+ for (winds = scm_dynwinds; SCM_NIMP (winds); winds = SCM_CDR (winds))
+ {
+ if (! SCM_CONSP (winds))
+ abort ();
- if (dynpair == SCM_BOOL_F)
- dynpair = scm_sloppy_assq (SCM_BOOL_T, scm_dynwinds);
+ dynpair = SCM_CAR (winds);
+ if (SCM_NIMP (dynpair) && SCM_CONSP (dynpair))
+ {
+ SCM this_key = SCM_CAR (dynpair);
- 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 (this_key == SCM_BOOL_T || this_key == key)
+ break;
+ }
}
+
+ /* If we didn't find anything, print a message and exit Guile. */
+ if (winds == SCM_EOL)
+ uncaught_throw (key, args);
+
+ if (SCM_IMP (winds) || SCM_NCONSP (winds))
+ abort ();
if (dynpair != SCM_BOOL_F)
jmpbuf = SCM_CDR (dynpair);
@@ -238,54 +315,53 @@ scm_ithrow (key, args, noreturn)
{
scm_exitval = scm_cons (key, args);
scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
+#ifdef DEBUG_EXTENSIONS
+ scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
+#endif
longjmp (SCM_JMPBUF (scm_rootcont), 1);
}
}
}
-#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));
+ if (!SCM_JMPBUFP (jmpbuf))
+ {
+ SCM_REDEFER_INTS;
+ scm_dynwinds = SCM_CDR (scm_dynwinds);
+ SCM_REALLOW_INTS;
+ return scm_apply (jmpbuf, scm_cons (key, args), SCM_EOL);
+ }
+ else
+ {
+ struct jmp_buf_and_retval * jbr;
+ jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
+ jbr->throw_tag = key;
+ jbr->retval = args;
+ }
+#ifdef DEBUG_EXTENSIONS
+ scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
+#endif
longjmp (*JBJMPBUF (jmpbuf), 1);
}
SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw);
-#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 */
+ /* May return if handled by lazy catch. */
+ return scm_ithrow (key, args, 1);
}
-#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
index f6aca5b24..3f41495bd 100644
--- a/libguile/throw.h
+++ b/libguile/throw.h
@@ -44,24 +44,14 @@
*/
-#include "__scm.h"
+#include "libguile/__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 */
-
-
+extern SCM scm_catch_apply SCM_P ((SCM tag, SCM proc, SCM a1, SCM args, SCM handler));
+extern SCM scm_catch SCM_P ((SCM tag, SCM thunk, SCM handler));
+extern SCM scm_lazy_catch SCM_P ((SCM tag, SCM thunk, SCM handler));
+extern SCM scm_ithrow SCM_P ((SCM key, SCM args, int noreturn));
+extern SCM scm_throw SCM_P ((SCM key, SCM args));
+extern void scm_init_throw SCM_P ((void));
#endif /* THROWH */
diff --git a/libguile/unif.c b/libguile/unif.c
index ed0e17c5c..5d604eeda 100644
--- a/libguile/unif.c
+++ b/libguile/unif.c
@@ -42,6 +42,16 @@
#include <stdio.h>
#include "_scm.h"
+#include "chars.h"
+#include "eval.h"
+#include "genio.h"
+#include "smob.h"
+#include "sequences.h"
+#include "strop.h"
+#include "feature.h"
+
+#include "unif.h"
+#include "ramap.h"
/* The set of uniform scm_vector types is:
@@ -493,7 +503,7 @@ scm_aind (ra, args, what)
if (SCM_INUMP (args))
{
- SCM_ASSERT (1 == k, SCM_UNDEFINED, SCM_WNA, what);
+ SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL);
return pos + (SCM_INUM (args) - s->lbnd) * (s->inc);
}
while (k && SCM_NIMP (args))
@@ -507,7 +517,8 @@ scm_aind (ra, args, what)
k--;
s++;
}
- SCM_ASSERT (0 == k && SCM_NULLP (args), SCM_UNDEFINED, SCM_WNA, what);
+ SCM_ASSERT (0 == k && SCM_NULLP (args), scm_makfrom0str (what), SCM_WNA,
+ NULL);
return pos;
}
@@ -600,7 +611,9 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
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_ASSERT (1 == scm_ilength (fill),
+ scm_makfrom0str (s_dimensions_to_uniform_array),
+ SCM_WNA, NULL);
scm_array_fill_x (answer, SCM_CAR (fill));
}
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
@@ -656,7 +669,9 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
}
if (SCM_NNULLP (fill))
{
- SCM_ASSERT (1 == scm_ilength (fill), fill, SCM_WNA, s_dimensions_to_uniform_array);
+ SCM_ASSERT (1 == scm_ilength (fill),
+ scm_makfrom0str (s_dimensions_to_uniform_array), SCM_WNA,
+ NULL);
scm_array_fill_x (ra, SCM_CAR (fill));
}
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
@@ -679,17 +694,19 @@ scm_ra_set_contp (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)
+ long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
+ while (k--)
{
- SCM_CAR (ra) &= ~SCM_ARRAY_CONTIGUOUS;
- return;
+ 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);
}
- inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
}
SCM_CAR (ra) |= SCM_ARRAY_CONTIGUOUS;
}
@@ -826,14 +843,15 @@ scm_transpose_array (args)
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);
+ SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (s_transpose_array),
+ SCM_WNA, NULL);
ra = SCM_CAR (args);
+ SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_transpose_array);
args = SCM_CDR (args);
- switch SCM_TYP7
- (ra)
+ switch (SCM_TYP7 (ra))
{
default:
- badarg:scm_wta (ra, (char *) SCM_ARG1, s_transpose_array);
+ badarg:scm_wta (ra, (char *) SCM_ARGn, s_transpose_array);
case scm_tc7_bvect:
case scm_tc7_string:
case scm_tc7_byvect:
@@ -846,14 +864,19 @@ scm_transpose_array (args)
#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);
+ SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)),
+ scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
+ SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2,
+ s_transpose_array);
+ SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE,
+ s_transpose_array);
return ra;
case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
vargs = scm_vector (args);
- SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), SCM_UNDEFINED, SCM_WNA, s_transpose_array);
- ve = SCM_VELTS (vargs);
+ SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra),
+ scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
+ ve = SCM_VELTS (vargs);
ndim = 0;
for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
{
@@ -916,7 +939,8 @@ scm_enclose_array (axes)
SCM axv, ra, res, ra_inr;
scm_array_dim vdim, *s = &vdim;
int ndim, j, k, ninr, noutr;
- SCM_ASSERT (SCM_NIMP (axes), SCM_UNDEFINED, SCM_WNA, s_enclose_array);
+ SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (s_enclose_array), SCM_WNA,
+ NULL);
ra = SCM_CAR (axes);
axes = SCM_CDR (axes);
if (SCM_NULLP (axes))
@@ -960,7 +984,8 @@ scm_enclose_array (axes)
}
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);
+ SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (s_enclose_array),
+ SCM_WNA, NULL);
res = scm_make_ra (noutr);
SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
SCM_ARRAY_V (res) = ra_inr;
@@ -1003,7 +1028,8 @@ scm_array_in_bounds_p (args)
register scm_sizet k;
register long j;
scm_array_dim *s;
- SCM_ASSERT (SCM_NIMP (args), args, SCM_WNA, s_array_in_bounds_p);
+ SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_array_in_bounds_p),
+ SCM_WNA, NULL);
v = SCM_CAR (args);
args = SCM_CDR (args);
SCM_ASRTGO (SCM_NIMP (v), badarg1);
@@ -1021,7 +1047,7 @@ tail:
{
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);
+ wna: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p));
case scm_tc7_smob:
k = SCM_ARRAY_NDIM (v);
s = SCM_ARRAY_DIMS (v);
@@ -1118,8 +1144,8 @@ scm_uniform_vector_ref (v, args)
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);
+ outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos));
+ wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref));
case scm_tc7_smob:
{ /* enclosed */
int k = SCM_ARRAY_NDIM (v);
@@ -1311,8 +1337,8 @@ scm_array_set_x (v, obj, args)
{
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);
+ outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos));
+ wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x));
case scm_tc7_smob: /* enclosed */
goto badarg1;
case scm_tc7_bvect:
@@ -2160,7 +2186,11 @@ scm_array_to_list (v)
static char s_bad_ralst[] = "Bad scm_array contents scm_list";
+#ifdef __STDC__
+static int l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k);
+#else
static int l2ra ();
+#endif
SCM_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array);
#ifdef __STDC__
@@ -2259,15 +2289,15 @@ l2ra (lst, ra, base, k)
#ifdef __STDC__
static void
-rapr1 (SCM ra, scm_sizet j, scm_sizet k, SCM port, int writing)
+rapr1 (SCM ra, scm_sizet j, scm_sizet k, SCM port, scm_print_state *pstate)
#else
static void
-rapr1 (ra, j, k, port, writing)
+rapr1 (ra, j, k, port, pstate)
SCM ra;
scm_sizet j;
scm_sizet k;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
long inc = 1;
@@ -2282,12 +2312,12 @@ tail:
{
SCM_ARRAY_BASE (ra) = j;
if (n-- > 0)
- scm_iprin1 (ra, port, writing);
+ scm_iprin1 (ra, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
SCM_ARRAY_BASE (ra) = j;
- scm_iprin1 (ra, port, writing);
+ scm_iprin1 (ra, port, pstate);
}
break;
}
@@ -2298,14 +2328,14 @@ tail:
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);
+ rapr1 (ra, j, k + 1, port, pstate);
scm_gen_puts (scm_regular_string, ") ", port);
j += inc;
}
if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
{ /* could be zero size. */
scm_gen_putc ('(', port);
- rapr1 (ra, j, k + 1, port, writing);
+ rapr1 (ra, j, k + 1, port, pstate);
scm_gen_putc (')', port);
}
break;
@@ -2322,21 +2352,21 @@ tail:
goto tail;
default:
if (n-- > 0)
- scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, writing);
+ scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
- scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, writing);
+ scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
}
break;
case scm_tc7_string:
if (n-- > 0)
- scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing);
- if (writing)
+ scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
+ if (SCM_WRITINGP (pstate))
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
- scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing);
+ scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
}
else
for (j += inc; n-- > 0; j += inc)
@@ -2380,12 +2410,12 @@ tail:
{
SCM z = scm_makflo (1.0);
SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
}
}
break;
@@ -2395,12 +2425,12 @@ tail:
{
SCM z = scm_makdbl (1.0 / 3.0, 0.0);
SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, writing);
+ scm_floprint (z, port, pstate);
}
}
break;
@@ -2410,13 +2440,13 @@ tail:
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);
+ scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_gen_putc (' ', port);
SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
- scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, writing);
+ scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
}
}
break;
@@ -2427,13 +2457,13 @@ tail:
#ifdef __STDC__
int
-scm_raprin1 (SCM exp, SCM port, int writing)
+scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
#else
int
-scm_raprin1 (exp, port, writing)
+scm_raprin1 (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
SCM v = exp;
@@ -2452,7 +2482,7 @@ tail:
{
scm_gen_puts (scm_regular_string, "<enclosed-array ", port);
- rapr1 (exp, base, 0, port, writing);
+ rapr1 (exp, base, 0, port, pstate);
scm_gen_putc ('>', port);
return 1;
}
@@ -2526,7 +2556,7 @@ tail:
#endif /*SCM_FLOATS*/
}
scm_gen_putc ('(', port);
- rapr1 (exp, base, 0, port, writing);
+ rapr1 (exp, base, 0, port, pstate);
scm_gen_putc (')', port);
return 1;
}
@@ -2636,13 +2666,13 @@ scm_init_unif ()
#ifdef __STDC__
int
-scm_raprin1 (SCM exp, SCM port, int writing)
+scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
#else
int
-scm_raprin1 (exp, port, writing)
+scm_raprin1 (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
return 0;
@@ -2661,19 +2691,6 @@ scm_istr2bve (str, len)
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 ()
{
diff --git a/libguile/unif.h b/libguile/unif.h
index 077621c6f..c112b4ff6 100644
--- a/libguile/unif.h
+++ b/libguile/unif.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
typedef struct scm_array
@@ -107,12 +107,9 @@ 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 int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate);
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 ();
@@ -151,9 +148,6 @@ 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 */
diff --git a/libguile/variable.c b/libguile/variable.c
index 984de26db..f0cb78120 100644
--- a/libguile/variable.c
+++ b/libguile/variable.c
@@ -42,7 +42,10 @@
#include <stdio.h>
#include "_scm.h"
+#include "genio.h"
+#include "smob.h"
+#include "variable.h"
#ifdef __STDC__
static scm_sizet
@@ -59,13 +62,13 @@ free_var (obj)
#ifdef __STDC__
static int
-prin_var (SCM exp, SCM port, int writing)
+prin_var (SCM exp, SCM port, scm_print_state *pstate)
#else
static int
-prin_var (exp, port, writing)
+prin_var (exp, port, pstate)
SCM exp;
SCM port;
- int writing;
+ scm_print_state *pstate;
#endif
{
scm_gen_puts (scm_regular_string, "#<variable ", port);
@@ -76,10 +79,10 @@ prin_var (exp, port, writing)
if (SCM_CAR (val_cell) != SCM_UNDEFINED)
{
scm_gen_puts (scm_regular_string, " name: ", port);
- scm_iprin1 (SCM_CAR (val_cell), port, writing);
+ scm_iprin1 (SCM_CAR (val_cell), port, pstate);
}
scm_gen_puts (scm_regular_string, " binding: ", port);
- scm_iprin1 (SCM_CDR (val_cell), port, writing);
+ scm_iprin1 (SCM_CDR (val_cell), port, pstate);
}
scm_gen_putc('>', port);
return 1;
diff --git a/libguile/variable.h b/libguile/variable.h
index b9d84fd8c..8de09879a 100644
--- a/libguile/variable.h
+++ b/libguile/variable.h
@@ -43,7 +43,7 @@
* If you do not wish that, delete this exception notice.
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -54,13 +54,13 @@ 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))))
+#define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
+#define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
#ifdef __STDC__
extern SCM scm_make_variable (SCM init, SCM name_hint);
-extern SCM scm_make_udvariable (SCM name_hint);
+extern SCM scm_make_undefined_variable (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);
@@ -70,7 +70,7 @@ extern void scm_init_variable (void);
#else /* STDC */
extern SCM scm_make_variable ();
-extern SCM scm_make_udvariable ();
+extern SCM scm_make_undefined_variable ();
extern SCM scm_variable_p ();
extern SCM scm_variable_ref ();
extern SCM scm_variable_set_x ();
diff --git a/libguile/vectors.c b/libguile/vectors.c
index c30a8590a..05e07d046 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -42,7 +42,9 @@
#include <stdio.h>
#include "_scm.h"
+#include "eq.h"
+#include "vectors.h"
@@ -154,7 +156,7 @@ scm_make_vector(k, fill, multip)
SCM_ASSERT(SCM_INUMP(k) && (0 <= SCM_INUM (k)), k, SCM_ARG1, s_make_vector);
if (SCM_UNBNDP(fill))
- fill = SCM_EOL;
+ fill = SCM_UNSPECIFIED;
multi = !(SCM_UNBNDP(multip) || SCM_FALSEP(multip));
i = SCM_INUM(k);
SCM_NEWCELL(v);
diff --git a/libguile/vectors.h b/libguile/vectors.h
index 3cf5c6478..4315224c8 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -64,6 +64,10 @@ 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 SCM scm_vector_move_left_x (SCM vec1, SCM start1, SCM end1, SCM
+ vec2, SCM start2);
+extern SCM scm_vector_move_right_x (SCM vec1, SCM start1, SCM end1, SCM
+ vec2, SCM start2);
extern void scm_init_vectors (void);
#else /* STDC */
@@ -76,6 +80,8 @@ extern SCM scm_make_vector();
extern SCM scm_vector_to_list();
extern SCM scm_vector_fill_x();
extern SCM scm_vector_equal_p();
+extern SCM scm_vector_move_left_x ();
+extern SCM scm_vector_move_right_x ();
extern void scm_init_vectors ();
#endif /* STDC */
diff --git a/libguile/version.c b/libguile/version.c
new file mode 100644
index 000000000..8b699f681
--- /dev/null
+++ b/libguile/version.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 "_scm.h"
+
+#include "version.h"
+
+
+/* Return a Scheme string containing Guile's major version number. */
+
+SCM_PROC(s_major_version, "major-version", 0, 0, 0, scm_major_version);
+#ifdef __STDC__
+SCM
+scm_major_version (void)
+#else
+SCM
+scm_major_version ()
+#endif
+{
+ return scm_makfrom0str (GUILE_MAJOR_VERSION);
+}
+
+/* Return a Scheme string containing Guile's minor version number. */
+
+SCM_PROC(s_minor_version, "minor-version", 0, 0, 0, scm_minor_version);
+#ifdef __STDC__
+SCM
+scm_minor_version (void)
+#else
+SCM
+scm_minor_version ()
+#endif
+{
+ return scm_makfrom0str (GUILE_MINOR_VERSION);
+}
+
+/* Return a Scheme string containing Guile's complete version. */
+
+SCM_PROC(s_version, "version", 0, 0, 0, scm_version);
+#ifdef __STDC__
+SCM
+scm_version (void)
+#else
+SCM
+scm_version ()
+#endif
+{
+ return scm_makfrom0str (GUILE_VERSION);
+}
+
+
+
+#ifdef __STDC__
+void
+scm_init_version (void)
+#else
+void
+scm_init_version ()
+#endif
+{
+#include "version.x"
+}
diff --git a/libguile/version.h b/libguile/version.h
new file mode 100644
index 000000000..24f6fc031
--- /dev/null
+++ b/libguile/version.h
@@ -0,0 +1,63 @@
+/* classes: h_files */
+
+#ifndef VERSIONH
+#define VERSIONH
+/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+
+#include "libguile/__scm.h"
+
+
+
+#ifdef __STDC__
+extern SCM scm_major_version (void);
+extern SCM scm_minor_version (void);
+extern SCM scm_version (void);
+extern void scm_init_version (void);
+#else /* STDC */
+extern SCM scm_major_version ();
+extern SCM scm_minor_version ();
+extern SCM scm_version ();
+extern void scm_init_version ();
+#endif /* STDC */
+
+#endif /* VERSIONH */
diff --git a/libguile/vports.c b/libguile/vports.c
index dbb67cbfe..71dec27a4 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -42,6 +42,15 @@
#include <stdio.h>
#include "_scm.h"
+#include "eval.h"
+#include "chars.h"
+#include "fports.h"
+
+#include "vports.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
diff --git a/libguile/vports.h b/libguile/vports.h
index 17a50fa57..465ee7549 100644
--- a/libguile/vports.h
+++ b/libguile/vports.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
extern scm_ptobfuns scm_sfptob;
diff --git a/libguile/weaks.c b/libguile/weaks.c
index 8479d76f5..8897f66cc 100644
--- a/libguile/weaks.c
+++ b/libguile/weaks.c
@@ -42,6 +42,7 @@
#include <stdio.h>
#include "_scm.h"
+#include "weaks.h"
@@ -119,18 +120,18 @@ scm_weak_vector_p (x)
-SCM_PROC(s_make_weak_hash_table, "make-weak-hash-table", 1, 0, 0, scm_make_weak_hash_table);
+SCM_PROC(s_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, scm_make_weak_key_hash_table);
#ifdef __STDC__
SCM
-scm_make_weak_hash_table (SCM k)
+scm_make_weak_key_hash_table (SCM k)
#else
SCM
-scm_make_weak_hash_table (k)
+scm_make_weak_key_hash_table (k)
SCM k;
#endif
{
SCM v;
- SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_hash_table);
+ SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_key_hash_table);
v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS;
SCM_VELTS (v)[-1] = 1;
@@ -171,7 +172,7 @@ scm_make_doubly_weak_hash_table (k)
#endif
{
SCM v;
- SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_value_hash_table);
+ SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_doubly_weak_hash_table);
v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS;
SCM_VELTS (v)[-1] = 3;
@@ -179,13 +180,13 @@ scm_make_doubly_weak_hash_table (k)
return v;
}
-SCM_PROC(s_weak_hash_table_p, "weak-hash-table?", 1, 0, 0, scm_weak_hash_table_p);
+SCM_PROC(s_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, scm_weak_key_hash_table_p);
#ifdef __STDC__
SCM
-scm_weak_hash_table_p (SCM x)
+scm_weak_key_hash_table_p (SCM x)
#else
SCM
-scm_weak_hash_table_p (x)
+scm_weak_key_hash_table_p (x)
SCM x;
#endif
{
diff --git a/libguile/weaks.h b/libguile/weaks.h
index 98e1cb698..a93aafe91 100644
--- a/libguile/weaks.h
+++ b/libguile/weaks.h
@@ -44,7 +44,7 @@
*/
-#include "__scm.h"
+#include "libguile/__scm.h"
@@ -60,10 +60,10 @@
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_key_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_key_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);
@@ -72,10 +72,10 @@ extern void scm_init_weaks (void);
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_key_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_key_hash_table_p ();
extern SCM scm_weak_value_hash_table_p ();
extern SCM scm_doubly_weak_hash_table_p ();
extern void scm_init_weaks ();