summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/.cvsignore8
-rw-r--r--libguile/COPYING339
-rw-r--r--libguile/ChangeLog-scm2610
-rw-r--r--libguile/DYNAMIC-LINKING95
-rw-r--r--libguile/Makefile.am60
-rw-r--r--libguile/Makefile.in478
-rw-r--r--libguile/__scm.h432
-rw-r--r--libguile/_scm.h124
-rw-r--r--libguile/acconfig.h81
-rw-r--r--libguile/acinclude.m40
-rw-r--r--libguile/aclocal.m4240
-rw-r--r--libguile/alist.c380
-rw-r--r--libguile/alist.h69
-rw-r--r--libguile/append.c78
-rw-r--r--libguile/append.h55
-rw-r--r--libguile/appinit.c52
-rw-r--r--libguile/arbiters.c133
-rw-r--r--libguile/arbiters.h56
-rw-r--r--libguile/async.c674
-rw-r--r--libguile/async.h71
-rw-r--r--libguile/backtrace.c436
-rw-r--r--libguile/backtrace.h58
-rw-r--r--libguile/boolean.c78
-rw-r--r--libguile/boolean.h67
-rw-r--r--libguile/chars.c408
-rw-r--r--libguile/chars.h90
-rwxr-xr-xlibguile/configure3057
-rw-r--r--libguile/configure.in218
-rw-r--r--libguile/continuations.c212
-rw-r--r--libguile/continuations.h78
-rw-r--r--libguile/dynl-dl.c212
-rw-r--r--libguile/dynl-dld.c187
-rw-r--r--libguile/dynl-shl.c172
-rw-r--r--libguile/dynl-vms.c106
-rw-r--r--libguile/dynl.c147
-rw-r--r--libguile/dynl.h57
-rw-r--r--libguile/dynwind.c139
-rw-r--r--libguile/dynwind.h54
-rw-r--r--libguile/eq.c152
-rw-r--r--libguile/eq.h55
-rw-r--r--libguile/error.c328
-rw-r--r--libguile/error.h84
-rw-r--r--libguile/eval.h170
-rw-r--r--libguile/extchrs.c134
-rw-r--r--libguile/extchrs.h74
-rw-r--r--libguile/feature.c121
-rw-r--r--libguile/feature.h55
-rw-r--r--libguile/filesys.c1311
-rw-r--r--libguile/filesys.h105
-rw-r--r--libguile/fports.c400
-rw-r--r--libguile/fports.h65
-rw-r--r--libguile/gc.c1825
-rw-r--r--libguile/gc.h101
-rw-r--r--libguile/gdb_interface.h127
-rw-r--r--libguile/gdbint.c325
-rw-r--r--libguile/gdbint.h58
-rw-r--r--libguile/genio.c508
-rw-r--r--libguile/genio.h59
-rw-r--r--libguile/gscm.c594
-rw-r--r--libguile/gscm.h281
-rw-r--r--libguile/gsubr.c193
-rw-r--r--libguile/gsubr.h55
-rw-r--r--libguile/guile-snarf.in4
-rw-r--r--libguile/hash.c222
-rw-r--r--libguile/hash.h60
-rw-r--r--libguile/hashtab.c540
-rw-r--r--libguile/hashtab.h84
-rw-r--r--libguile/inet_aton.c157
-rw-r--r--libguile/init.c454
-rw-r--r--libguile/init.h56
-rw-r--r--libguile/ioext.c458
-rw-r--r--libguile/ioext.h68
-rw-r--r--libguile/kw.c148
-rw-r--r--libguile/kw.h63
-rw-r--r--libguile/libguile.h131
-rw-r--r--libguile/list.c655
-rw-r--r--libguile/list.h82
-rw-r--r--libguile/load.c343
-rw-r--r--libguile/load.h60
-rw-r--r--libguile/mallocs.c105
-rw-r--r--libguile/mallocs.h60
-rw-r--r--libguile/markers.c81
-rw-r--r--libguile/markers.h59
-rw-r--r--libguile/mbstrings.c505
-rw-r--r--libguile/mbstrings.h78
-rw-r--r--libguile/numbers.c3704
-rw-r--r--libguile/numbers.h323
-rw-r--r--libguile/objprop.c120
-rw-r--r--libguile/objprop.h62
-rw-r--r--libguile/options.c227
-rw-r--r--libguile/options.h73
-rw-r--r--libguile/pairs.c163
-rw-r--r--libguile/pairs.h172
-rw-r--r--libguile/ports.c854
-rw-r--r--libguile/ports.h200
-rw-r--r--libguile/posix.c1461
-rw-r--r--libguile/posix.h101
-rw-r--r--libguile/print.c860
-rw-r--r--libguile/print.h100
-rw-r--r--libguile/procprop.c138
-rw-r--r--libguile/procprop.h61
-rw-r--r--libguile/procs.c199
-rw-r--r--libguile/procs.h103
-rw-r--r--libguile/ramap.c2127
-rw-r--r--libguile/ramap.h73
-rw-r--r--libguile/read.c768
-rw-r--r--libguile/read.h89
-rw-r--r--libguile/root.c378
-rw-r--r--libguile/root.h157
-rw-r--r--libguile/scmconfig.h.in287
-rw-r--r--libguile/scmhob.h205
-rw-r--r--libguile/scmsigs.c368
-rw-r--r--libguile/scmsigs.h60
-rw-r--r--libguile/sequences.c113
-rw-r--r--libguile/sequences.h59
-rw-r--r--libguile/simpos.c152
-rw-r--r--libguile/simpos.h55
-rw-r--r--libguile/smob.c129
-rw-r--r--libguile/smob.h78
-rw-r--r--libguile/snarf.h94
-rw-r--r--libguile/socket.c398
-rw-r--r--libguile/socket.h69
-rw-r--r--libguile/srcprop.c363
-rw-r--r--libguile/srcprop.h134
-rw-r--r--libguile/stackchk.c104
-rw-r--r--libguile/stackchk.h92
-rw-r--r--libguile/stacks.h135
-rw-r--r--libguile/stamp-h.in0
-rw-r--r--libguile/stime.c206
-rw-r--r--libguile/stime.h56
-rw-r--r--libguile/strerror.c32
-rw-r--r--libguile/strings.c407
-rw-r--r--libguile/strings.h79
-rw-r--r--libguile/strop.c325
-rw-r--r--libguile/strop.h65
-rw-r--r--libguile/strorder.c224
-rw-r--r--libguile/strorder.h68
-rw-r--r--libguile/strports.c304
-rw-r--r--libguile/strports.h61
-rw-r--r--libguile/struct.c607
-rw-r--r--libguile/struct.h86
-rw-r--r--libguile/symbols.c727
-rw-r--r--libguile/symbols.h132
-rw-r--r--libguile/tag.c215
-rw-r--r--libguile/tag.h58
-rw-r--r--libguile/tags.h539
-rw-r--r--libguile/throw.c496
-rw-r--r--libguile/throw.h65
-rw-r--r--libguile/unif.c2538
-rw-r--r--libguile/unif.h114
-rw-r--r--libguile/variable.c249
-rw-r--r--libguile/variable.h71
-rw-r--r--libguile/vectors.c271
-rw-r--r--libguile/vectors.h73
-rw-r--r--libguile/version.c85
-rw-r--r--libguile/version.h56
-rw-r--r--libguile/vports.c226
-rw-r--r--libguile/vports.h59
-rw-r--r--libguile/weaks.c203
-rw-r--r--libguile/weaks.h71
160 files changed, 0 insertions, 47640 deletions
diff --git a/libguile/.cvsignore b/libguile/.cvsignore
deleted file mode 100644
index e4632e405..000000000
--- a/libguile/.cvsignore
+++ /dev/null
@@ -1,8 +0,0 @@
-Makefile
-config.log
-config.status
-config.cache
-fd.h
-scmconfig.h
-*.x
-libpath.h \ No newline at end of file
diff --git a/libguile/COPYING b/libguile/COPYING
deleted file mode 100644
index 9648fb9ea..000000000
--- a/libguile/COPYING
+++ /dev/null
@@ -1,339 +0,0 @@
- GNU GENERAL PUBLIC LICENSE
- Version 2, June 1991
-
- Copyright (C) 1989, 1991, 1992, 1993 Free Software Foundation, Inc.
- 675 Mass Ave, Cambridge, MA 02139, USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- Preamble
-
- The licenses for most software are designed to take away your
-freedom to share and change it. By contrast, the GNU General Public
-License is intended to guarantee your freedom to share and change free
-software--to make sure the software is free for all its users. This
-General Public License applies to most of the Free Software
-Foundation's software and to any other program whose authors commit to
-using it. (Some other Free Software Foundation software is covered by
-the GNU Library General Public License instead.) You can apply it to
-your programs, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-this service if you wish), that you receive source code or can get it
-if you want it, that you can change the software or use pieces of it
-in new free programs; and that you know you can do these things.
-
- To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the rights.
-These restrictions translate to certain responsibilities for you if you
-distribute copies of the software, or if you modify it.
-
- For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must give the recipients all the rights that
-you have. You must make sure that they, too, receive or can get the
-source code. And you must show them these terms so they know their
-rights.
-
- We protect your rights with two steps: (1) copyright the software, and
-(2) offer you this license which gives you legal permission to copy,
-distribute and/or modify the software.
-
- Also, for each author's protection and ours, we want to make certain
-that everyone understands that there is no warranty for this free
-software. If the software is modified by someone else and passed on, we
-want its recipients to know that what they have is not the original, so
-that any problems introduced by others will not reflect on the original
-authors' reputations.
-
- Finally, any free program is threatened constantly by software
-patents. We wish to avoid the danger that redistributors of a free
-program will individually obtain patent licenses, in effect making the
-program proprietary. To prevent this, we have made it clear that any
-patent must be licensed for everyone's free use or not licensed at all.
-
- The precise terms and conditions for copying, distribution and
-modification follow.
-
- GNU GENERAL PUBLIC LICENSE
- TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
- 0. This License applies to any program or other work which contains
-a notice placed by the copyright holder saying it may be distributed
-under the terms of this General Public License. The "Program", below,
-refers to any such program or work, and a "work based on the Program"
-means either the Program or any derivative work under copyright law:
-that is to say, a work containing the Program or a portion of it,
-either verbatim or with modifications and/or translated into another
-language. (Hereinafter, translation is included without limitation in
-the term "modification".) Each licensee is addressed as "you".
-
-Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope. The act of
-running the Program is not restricted, and the output from the Program
-is covered only if its contents constitute a work based on the
-Program (independent of having been made by running the Program).
-Whether that is true depends on what the Program does.
-
- 1. You may copy and distribute verbatim copies of the Program's
-source code as you receive it, in any medium, provided that you
-conspicuously and appropriately publish on each copy an appropriate
-copyright notice and disclaimer of warranty; keep intact all the
-notices that refer to this License and to the absence of any warranty;
-and give any other recipients of the Program a copy of this License
-along with the Program.
-
-You may charge a fee for the physical act of transferring a copy, and
-you may at your option offer warranty protection in exchange for a fee.
-
- 2. You may modify your copy or copies of the Program or any portion
-of it, thus forming a work based on the Program, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
-
- a) You must cause the modified files to carry prominent notices
- stating that you changed the files and the date of any change.
-
- b) You must cause any work that you distribute or publish, that in
- whole or in part contains or is derived from the Program or any
- part thereof, to be licensed as a whole at no charge to all third
- parties under the terms of this License.
-
- c) If the modified program normally reads commands interactively
- when run, you must cause it, when started running for such
- interactive use in the most ordinary way, to print or display an
- announcement including an appropriate copyright notice and a
- notice that there is no warranty (or else, saying that you provide
- a warranty) and that users may redistribute the program under
- these conditions, and telling the user how to view a copy of this
- License. (Exception: if the Program itself is interactive but
- does not normally print such an announcement, your work based on
- the Program is not required to print an announcement.)
-
-These requirements apply to the modified work as a whole. If
-identifiable sections of that work are not derived from the Program,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works. But when you
-distribute the same sections as part of a whole which is a work based
-on the Program, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Program.
-
-In addition, mere aggregation of another work not based on the Program
-with the Program (or with a work based on the Program) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
- 3. You may copy and distribute the Program (or a work based on it,
-under Section 2) in object code or executable form under the terms of
-Sections 1 and 2 above provided that you also do one of the following:
-
- a) Accompany it with the complete corresponding machine-readable
- source code, which must be distributed under the terms of Sections
- 1 and 2 above on a medium customarily used for software interchange; or,
-
- b) Accompany it with a written offer, valid for at least three
- years, to give any third party, for a charge no more than your
- cost of physically performing source distribution, a complete
- machine-readable copy of the corresponding source code, to be
- distributed under the terms of Sections 1 and 2 above on a medium
- customarily used for software interchange; or,
-
- c) Accompany it with the information you received as to the offer
- to distribute corresponding source code. (This alternative is
- allowed only for noncommercial distribution and only if you
- received the program in object code or executable form with such
- an offer, in accord with Subsection b above.)
-
-The source code for a work means the preferred form of the work for
-making modifications to it. For an executable work, complete source
-code means all the source code for all modules it contains, plus any
-associated interface definition files, plus the scripts used to
-control compilation and installation of the executable. However, as a
-special exception, the source code distributed need not include
-anything that is normally distributed (in either source or binary
-form) with the major components (compiler, kernel, and so on) of the
-operating system on which the executable runs, unless that component
-itself accompanies the executable.
-
-If distribution of executable or object code is made by offering
-access to copy from a designated place, then offering equivalent
-access to copy the source code from the same place counts as
-distribution of the source code, even though third parties are not
-compelled to copy the source along with the object code.
-
- 4. You may not copy, modify, sublicense, or distribute the Program
-except as expressly provided under this License. Any attempt
-otherwise to copy, modify, sublicense or distribute the Program is
-void, and will automatically terminate your rights under this License.
-However, parties who have received copies, or rights, from you under
-this License will not have their licenses terminated so long as such
-parties remain in full compliance.
-
- 5. You are not required to accept this License, since you have not
-signed it. However, nothing else grants you permission to modify or
-distribute the Program or its derivative works. These actions are
-prohibited by law if you do not accept this License. Therefore, by
-modifying or distributing the Program (or any work based on the
-Program), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Program or works based on it.
-
- 6. Each time you redistribute the Program (or any work based on the
-Program), the recipient automatically receives a license from the
-original licensor to copy, distribute or modify the Program subject to
-these terms and conditions. You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties to
-this License.
-
- 7. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Program at all. For example, if a patent
-license would not permit royalty-free redistribution of the Program by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Program.
-
-If any portion of this section is held invalid or unenforceable under
-any particular circumstance, the balance of the section is intended to
-apply and the section as a whole is intended to apply in other
-circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system, which is
-implemented by public license practices. Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-
- 8. If the distribution and/or use of the Program is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Program under this License
-may add an explicit geographical distribution limitation excluding
-those countries, so that distribution is permitted only in or among
-countries not thus excluded. In such case, this License incorporates
-the limitation as if written in the body of this License.
-
- 9. The Free Software Foundation may publish revised and/or new versions
-of the General Public License from time to time. Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
-Each version is given a distinguishing version number. If the Program
-specifies a version number of this License which applies to it and "any
-later version", you have the option of following the terms and conditions
-either of that version or of any later version published by the Free
-Software Foundation. If the Program does not specify a version number of
-this License, you may choose any version ever published by the Free Software
-Foundation.
-
- 10. If you wish to incorporate parts of the Program into other free
-programs whose distribution conditions are different, write to the author
-to ask for permission. For software which is copyrighted by the Free
-Software Foundation, write to the Free Software Foundation; we sometimes
-make exceptions for this. Our decision will be guided by the two goals
-of preserving the free status of all derivatives of our free software and
-of promoting the sharing and reuse of software generally.
-
- NO WARRANTY
-
- 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
-FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
-OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
-PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
-OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
-TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
-PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
-REPAIR OR CORRECTION.
-
- 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
-REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
-INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
-OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
-TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
-YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
-PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGES.
-
- END OF TERMS AND CONDITIONS
-
- Appendix: How to Apply These Terms to Your New Programs
-
- If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
- To do so, attach the following notices to the program. It is safest
-to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
- <one line to give the program's name and a brief idea of what it does.>
- Copyright (C) 19yy <name of author>
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-Also add information on how to contact you by electronic and paper mail.
-
-If the program is interactive, make it output a short notice like this
-when it starts in an interactive mode:
-
- Gnomovision version 69, Copyright (C) 19yy name of author
- Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
- This is free software, and you are welcome to redistribute it
- under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License. Of course, the commands you use may
-be called something other than `show w' and `show c'; they could even be
-mouse-clicks or menu items--whatever suits your program.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the program, if
-necessary. Here is a sample; alter the names:
-
- Yoyodyne, Inc., hereby disclaims all copyright interest in the program
- `Gnomovision' (which makes passes at compilers) written by James Hacker.
-
- <signature of Ty Coon>, 1 April 1989
- Ty Coon, President of Vice
-
-This General Public License does not permit incorporating your program into
-proprietary programs. If your program is a subroutine library, you may
-consider it more useful to permit linking proprietary applications with the
-library. If this is what you want to do, use the GNU Library General
-Public License instead of this License.
diff --git a/libguile/ChangeLog-scm b/libguile/ChangeLog-scm
deleted file mode 100644
index 0ba497ed7..000000000
--- a/libguile/ChangeLog-scm
+++ /dev/null
@@ -1,2610 +0,0 @@
-Wed Apr 5 14:32:51 1995 Gary Houston <ghouston@actrix.gen.nz>
-
- * unix.c, ioext.c, posix.c, sys.c: Scheme name changes,
- semantic cleanups, the port table, missing system calls
- and coding cleanups from ghouston@actrix.gen.nz
-
-Thu Mar 16 14:37:38 1995 Tom Lord <lord@x1.cygnus.com>
-
- * guile.c: fixed the gcc-specific definition of the macro "AT(x)".
-
- * guile.c (gscm_init_from_fn): Parameterize what init functions
- get called (see guile_ks, below).
-
- * guile-mini.c (guile_mini): a minimalist alternative to guile_ks.
-
- * guile-ks.c (guile_ks): factor out the call to optional inits to
- a separate file so you can link against libguile without getting
- the kitchen sink.
-
- * Ginit.scm (try-load of "ScmInit.scm"): Be robust in the absense
- of a binding for the environment varialbe HOME. Try
- (getpw (geteuid)) or just use "/".
-
-
-Thu Mar 9 15:35:20 1995 Tom Lord <lord@x1.cygnus.com>
-
- * gmain.c (main): Print additional error message if init file
- can't be opened.
-
- * guile.c (initialize_gscm): Report an error if the
- init file can't be opened.
-
-Thu Mar 23 23:22:59 1995 Aubrey Jaffer (jaffer@jacal)
-
- * scm.texi (I/O-Extensions): Finished.
-
- * Init.scm (scm:load): `loading' messages now indented.
-
-Sat Mar 4 20:58:51 1995 Aubrey Jaffer (jaffer@jacal)
-
- * scm.texi: documentation finished for "posix.c" and "unix.c".
-
- * posix.c (scm_getgroups): added.
-
- * posix.c (makfrom0str): According to glibc.info, some field in
- structures like pwent may have NULL pointers. Changed makfrom0str
- to return BOOL_F in this case.
-
-Thu Mar 2 12:52:25 1995 Aubrey Jaffer (jaffer@jacal)
-
- * time.c: CLKTCK set from CLOCKS_PER_SEC, if available. Metaware
- HighC ported.
-
- * scm.h: USE_ANSI_PROTOTYPES now controls prototypes (was
- __STDC__). This allows an overly fussy compiler to still have
- __STDC__.
-
- From: dorai@ses.com (Dorai Sitaram)
- * ioext.c (l_utime): include files fixed for __EMX__
-
-Sun Feb 26 23:46:18 1995 Tom Lord <lord@x1.cygnus.com>
-
- * repl.c (scm_app_wdr): Like scm_apply, but takes an error function.
- The caller's continuation is never captured or escaped.
- The error function is invoked as with scm_cwdr.
-
-Sun Feb 26 21:03:04 1995 Aubrey Jaffer (jaffer@jacal)
-
- * sys.c (gc_mark gc_sweep): tc7_ssymbol now gets GCed because it
- gets used for non-GCed strings in scm_evalstr scm_loadstr.
- (mkstrport cwos cwis): changed so caller's name is passed into
- mkstrport().
-
- * repl.c
- (scm_eval_string scm_evalstr scm_load_string scm_loadstr): added
- for easier C to scheme callbacks.
- (loadport): variable added so lreadr() and flush_ws()
- increment linum only when reading from the correct port.
- (def_err_response): now handles ARGn for argument numbers > 5 and
- unknown position arguments.
-
- * dynl.c: Dynamic Linking now sets and restores *load-pathname*
- around the init_ call.
-
-Sat Feb 25 11:03:56 1995 Aubrey Jaffer (jaffer@jacal)
-
- * scm.c (lsystem getenv softtype ed vms_debug): moved from scl.c.
- (add_feature): moved from repl.c.
- (features): init table removed (caused multiple symbols).
-
-Fri Feb 24 23:48:03 1995 Aubrey Jaffer (jaffer@jacal)
-
- * scm.c (scm_init_extensions COMPILED_INITS): Added so that
- statically linked, compiled code can be initialized *after* most
- of Init.scm has loaded.
-
-Wed Feb 22 15:54:01 1995 Aubrey Jaffer (jaffer@jacal)
-
- * subr.c (append): Added check for bad arguments and fixed errobj.
-
-Sun Feb 19 01:31:59 1995 Aubrey Jaffer (jaffer@jacal)
-
- * ioext.c (exec execp): changed so that 2nd arguments is argv[0]
- (like posix) and renamed to execl and execlp.
- (execv execvp): added.
-
-Sat Feb 11 17:30:14 1995 Aubrey Jaffer (jaffer@jacal)
-
- * ioext.c (lexec): moved from repl.c and scm.c.
- (lexecp i_exec l_putenv): added.
-
- * posix.c (open_pipe l_open_input_pipe l_open_output_pipe
- prinpipe): moved from ioext.c.
- (l_fork): added.
-
-Fri Feb 10 10:50:03 1995 Aubrey Jaffer (jaffer@jacal)
-
- * scl.c (num2long long2num): moved here from subr.c.
- (num2ulong): fixed (< to >=) bug.
-
- * unif.c (aset array2list array_ref cvref): uniform integers and
- unsigned integer arrays now handle full size integers (and
- inexacts) using num2long, num2ulong, long2num, and ulong2num when
- INUMS_ONLY is not defined.
-
- * scmfig.h (INUMS_ONLY): defined when INUMs are the only numbers.
-
-Wed Feb 8 17:57:26 1995 Tom Lord (lord@x1.cygnus.com)
-
- * Ginit.scm (stand-alone-repl): Use new function (rooted-repl)
- (rooted-repl): new function
-
-Tue Jan 31 16:46:26 1995 Tom Lord (lord@x1.cygnus.com)
-
- * repl.c (lreadr): compare string constant names
- in a case insensative way.
-
- (scm_lread): Take an optional parameter CASEP.
- If specified and not #f, then symbols are read
- in a case sensative way.
-
- If not specified, the state variable default_case_i is checked
- (a C int, either 0 or 1). The state variable hasn't been
- exposed and so is constant and depends on compile-time flags --
- but in the future it might be made more explicit if there is a
- need.
-
-Sun Jan 29 23:22:40 1995 Aubrey Jaffer (jaffer@jacal)
-
- * scm.texi (Overview): scm.1 converted to texinfo format and
- incorporated.
-
-Sat Jan 28 23:11:40 1995 Tom Lord (lord@x1.cygnus.com)
-
- * repl.c (compiled-library-path): return the value of the
- compile-time cpp macro "LIBRARY_PATH" or #f.
-
- * Ginit.scm: use the above path to find slib on unix.
- This solution should be generalized.
-
-Fri Jan 27 19:58:27 1995 Tom Lord (lord@x1.cygnus.com)
-
- * sys.c (gc_sweep): Fixed a gc bug that caused circular free-lists
- resulting in Cells that thought they were free long after they
- were allocated for some nefarious purpose or other.
-
- * Makefile.in (manifest): ship all pieces of the info manual.
- Typos fixes from ghouston.
-
-Thu Jan 26 01:52:00 1995 Tom Lord <lord@x1.cygnus.com>
-
- From: cessu@cs.hut.fi (Kenneth Oksanen)
-
- * configure.in:
- AC_CHECK_LIB(nsl, gethostent)
- AC_CHECK_LIB(ucb, bzero)
- AC_CHECK_LIB(socket, socket)
- AC_CHECK_LIB(bsd, bzero)
-
-
- From: brent@jade.ssd.csd.harris.com (Brent Benson)
-
- * gmain.c: line 31: In ANSI C, string literals cannot span multiple
- source lines.
-
- * guile.c: line 592: The two cases in the ifdef are reversed, AT(X)
- should expand to nothing if you are *not* using GNUC.
-
- * ioext.c: line 29: On my system it is necessary to
- include <unistd.h> *before* <sys/stat.h> in order to
- have the correct types defined.
-
- * ioext.c: line 194: Declaration of popen conflicts with my system's
- popen() defined in <unistd.h>. Let the header file provide the
- prototype!!
-
-Sun Jan 22 11:13:58 1995 Aubrey Jaffer (jaffer@jacal)
-
- * scm.texi (Internals): code.doc converted to texinfo format.
- Much added and reorganized. code.doc removed.
-
-Thu Jan 19 00:40:11 1995 Aubrey Jaffer (jaffer@jacal)
-
- * subr.c (logbitp logtest): added.
-
-Mon Jan 16 01:42:20 1995 Tom Lord <lord@x1.cygnus.com>
-
- * repl.c (scm_repl): takes two arguments now (prompt and top-level).
- Callable from Scheme.
-
- * sys.c (scm_init_storage): only use stdin if scm_take_stdin is true.
- Otherwise, use an empty string port. If using stdin, make it
- unbuffered.
-
-Sun Jan 15 21:51:37 1995 Tom Lord <lord@x1.cygnus.com>
-
- * sys.c (scm_mkarray, scm_free_array, mark_arrays): support for
- C programs. malloc/free style interface to allcoating
- protected storage of type SCM*.
-
-Sun Jan 15 17:49:43 1995 Tom Lord (lord@x1.cygnus.com)
-
- * guile.c: new file. Friendly C interface for Guile.
- (see file GUILE)
-
- * repl.c (scm_cwdr): added call-with-dynamic-root (see scm.texi).
-
-Sat Jan 14 23:35:21 1995 Tom Lord (lord@x1.cygnus.com)
-
- * repl.c, subr.c: re-arrangement, commenting
- of source in preparation for pulling repls apart
- for libguile.
-
-Wed Jan 11 14:45:17 1995 Aubrey Jaffer (jaffer@jacal)
-
- * scl.c (num2ulong): checks for bignum sign and magnitude added.
-
- * subr.c (logand logior logxor lognot): lognot restriction to
- INUMs removed. Logand, logior, and logxor now will work for up to
- 32 bit signed numbers.
-
-Tue Jan 10 13:19:52 1995 Aubrey Jaffer (jaffer@jacal)
-
- * repl.c (def_err_response): Circuitous call to quit() replaced
- with exit(EXIT_FAILURE);
- (everr): Now calls def_err_response() in interrupt frame if
- errjmp_bad or there are dynwinds to do. This prevents silent
- failure in batch mode.
-
-
-Mon Jan 9 00:12:14 1995 Aubrey Jaffer (jaffer@jacal)
-
- * repl.c (handle_it): Now discards possibly used top freelist cell
- for GC safety. Also now just punts if errjmp_bad.
-
- * scm.texi: converted from MANUAL. GUILE documentation merged in.
-
-Sat Jan 7 13:51:04 1995 Miles Bader (miles@eskimo.com)
-
- * mrequire.scm: New file: Wrapper for slib require/provide that
- makes it modular (that is, each slib package is loaded into its
- own module, and sees only other modules that it requires).
-
- * defmod.scm: Allow use-interface in the default module.
-
- * libguile.scm: Put symbols common to both guile and scm
- interfaces into the internal interface `EXTRA' (which is included
- by both). Other random shuffling, mostly to make slib happy.
-
- * modops.scm (extend-interface, export-interface, export): Add
- another operation type, #f, which turns off automatic exporting of
- the current source interface when finishing up with it. This is
- used by export-interface to prevent trying to export all symbols.
-
- * modops.scm (import): No longer signal an error when trying to
- export a whole module, as we want to do this sometimes.
-
- * Ginit.scm: No longer try to load require.scm, or depend on it;
- In the case of getopt, we just load it manually. Also make
- defmacro module-safe.
-
-Sat Jan 7 01:54:11 1995 Tom Lord <lord@x1.cygnus.com>
-
- * sys.c (scm_intern_obarray_soft): Reserve room for symbol slots.
-
- * sys.c (scm_makstr, scm_makfromstr): added an extra parameter SLOTS.
- The parameter means:
- 0: same as the old behavior
- 1: not useful
- > 1: allocate SLOTS - 1 extra slots in the string storage.
-
- The base address of SLOTS, an array of SCM, is at SLOTS(obj).
- This is for symbol slots, and later for procedure slots.
- If you use this in the constructor for your new type (usually
- done by creating a string and then invoking SETLENGTH to change
- its type), you are responsible for making sure slot contents
- are properly gc'ed.
-
- Callers of these were fixed as well.
-
-Tue Jan 3 14:30:34 1995 Miles Bader (miles@eskimo.com)
-
- * modops.scm, extlibs.scm, libguile.scm, defmod.scm: New files:
- These implement the user-level module system.
-
- * sys.c (scm_sym2vcell): Add another argument: definedp, which is
- passed as additional argument to the lookup-thunk (if any).
- If this argument is BOOL_T, this lookup is for a define (which
- has somewhat different semantics for modules); otherwise it
- should be satisfied with an existing variable. If the thunk
- returns BOOL_F (meaning there was no such variable), sym2vcell
- returns BOOL_F as well.
- * eval.c (scm_lookupcar, scm_m_define): Use the new sym2vcell param.
- * variable.c (scm_builtin_var): Use the new sym2vcell param.
-
- * eval.c (scm_top_level_env): New function: return an environment
- using the given top-level-lookup thunk.
- * eval.c (scm_eval2): Use scm_top_level_env.
- * eval.c (scm_eval): Use an env with a top-level lookup thunk from
- scm_top_level_lookup_thunk_var (aka *top-level-lookup-thunk*).
- * eval.c (scm_neval): New function: just like scm_eval, but may
- destroy its argument. Known in scheme as eval!.
-
- * repl.c (scm_repl, scm_tryload, lreadr): Use scm_neval, not eval_3.
-
- * Ginit.scm (make-module): Use the new definition of top-level thunks.
- * Ginit.scm (set-current-module): Set *top-level-lookup-thunk* too.
- * Ginit.scm: Trash all the repl stuff; we just use the C repl now.
- Load the user module system.
-
- * Makefile.in: Install the user-module implementation files.
-
-Mon Jan 2 16:27:25 1995 Miles Bader (miles@eskimo.com)
-
- * Ginit.scm (repl:repl): Have the guile repl redefine try-load
- instead of load, as this is the SCM primitive.
- (module-for-each): Write module-for-each.
- (module-search): Make this recurse into each module use-list
- entry, as per the low-level module spec.
- (define-macro): Make this function usable by modules that don't
- have access to the internals of the guile module.
-
-Sun Jan 1 22:30:25 1995 Tom Lord <lord@x1.cygnus.com>
-
- * repl.c (scm_iprin1), subr.c (scm_lock_vector, scm_unlock_vector,
- scm_lvector_ref, scm_lvector_set):
-
- Added locked vectors. See N
-
-Sat Dec 31 15:45:22 1994 Miles Bader <miles@eskimo.com>
-
- * Ginit.scm:
- Add define-macro, delq!.
-
- Add a module print-function, and some new name fields
- to the module that the modops code uses to make modules
- print nicely (e.g., #<interface guile/module 7a89c>)
-
-
- * eval.c(ceval): Here's a patch that makes closures & subrs
- self-evaluating.
-
-
-Wed Dec 28 00:31:22 1994 Tom Lord <lord@cygnus.com>
-
- * scm.c (raise): use kill not raise, since it is more portable.
-
-Wed Dec 21 05:18:47 1994 Tom Lord <lord@x1.cygnus.com>
-
- * eval.c (scm_eval2): Two argument eval. The
- second argument is #f or a proc returning a variable.
-
-Fri Dec 9 00:40:26 1994 Tom Lord <lord@x1.cygnus.com>
-
- * eval.c (scm_fasl_eval): eval without copying the source form.
- This is just a temporary hack.
-
-Sun Dec 4 21:50:37 1994 Tom Lord <lord@x1.cygnus.com>
-
- * eval.c (scm_ceval): Added special forms LITERAL-VARIABLE-SET!
- and LITERAL-VARIABLE-REF. The first argument of each is a
- variable object (see variable.c). The second argument
- of set! is an expression. They do what you'd expect.
- -SET! returns UNSPECIFIED.
-
- Note that one can not read a form which uses literal-variable*
- correctly because there is no way to read a variable object.
- These forms exist for the sake of the module system.
-
-Fri Dec 2 19:52:40 1994 Tom Lord (lord@x1.cygnus.com)
-
- * subr.c (string->obarray-symbol, intern-symbol, unintern-symbol,
- symbol-set!, symbol-binding)
- Multiple obarrays.
-
- * variable.c (scm_make_variable, scm_variable_{ref,set}
- Implemented variables. Variables are anonymous
- objects holding one settable value.
-
-Wed Nov 30 04:31:18 1994 Tom Lord (lord@x1.cygnus.com)
-
- * *.[ch]: renamed all global identifiers to have the prefix scm_.
-
- * sys.c (gc_sweep, scm_mark_locations, scm_init_heap):
-
- Modified gc to allow objects of any multiple of sizeof(CELLPTR).
- In addition, each heap segment gets to specify a freelist (which
- may be shared).
-
- new function: scm_alloc_obj
- new vars: scm_heap_table (replaces hplims)
- scm_n_heap_segs (replaces (hpims_ind / 2))
-
-Thu Oct 27 12:57:02 1994 Aubrey Jaffer (jaffer@jacal)
-
- From: Jerry D. Hedden <hedden@esdsdf.dnet.ge.com>
- * ioext.c: conditional code for vms and version (3.6) of Aztec C.
- * pi.scm ((e digits)): Modified 'bigpi' for slight speed
- improvement. Added function to calculate digits of 'e'.
-
-Wed Oct 26 11:22:05 1994 Aubrey Jaffer (jaffer@jacal)
-
- From: Gary Houston <ghouston@actrix.gen.nz>
- * scl.c (round): Now rounds as described in R4RS.
-
- * test.scm (test-inexact): test cases for round.
-
-Tue Oct 25 00:02:27 1994 Aubrey Jaffer (jaffer@jacal)
-
- * sys.c (grow_throw lthrow dynthrow): now pass arrays, check
- for adequate growth, and clear out register windows (on sparc).
-
-Mon Oct 24 01:05:34 1994 Aubrey Jaffer (jaffer@jacal)
-
- * ioext.c (ttyname fileno): added.
-
-Sat Oct 22 12:12:57 1994 Aubrey Jaffer (jaffer@jacal)
-
- * unix.c (symlink readlink lstat): added.
-
- * scmfig.h repl.c sys.c (IO_EXTENSIONS): flag removed.
-
- * ioext.c (read-line read-line! file-position, file-set-position
- reopen-file open-pipe opendir readdir rewinddir closedir chdir
- umask rename-file isatty? access chmod mkdir rmdir stat utime
- raise): moved from "repl.c" and "sys.c".
-
-Fri Oct 21 21:19:13 1994 Aubrey Jaffer (jaffer@jacal)
-
- From: Radey Shouman <shouman@ccwf.cc.utexas.edu>
- * unif.c (ra2contig): now has a second parameter to indicate
- whether copying is necessary or not. Eliminates gratuitous copy
- by UNIFORM-ARRAY-READ! when called with a noncontiguous array.
-
- (array_map): more liberal check on when ARRAY-MAP! can use
- array-ified asubrs.
-
-Thu Oct 20 18:00:35 1994 Aubrey Jaffer (jaffer@jacal)
-
- * sys.c (opendir readdir rewinddir closedir reopen-file): added
- under IO_EXTENSIONS.
-
-Wed Oct 19 14:18:26 1994 Aubrey Jaffer (jaffer@jacal)
-
- * eval.c (badargsp): added under ifndef RECKLESS to check @apply
- and apply() arg counts.
-
-Tue Oct 18 00:02:10 1994 Aubrey Jaffer (jaffer@jacal)
-
- * unix.c (mknod acct nice sync): added.
-
- * socket.c (socket bind! gethost connect! listen! accept): added.
-
- * time.c (utime): added under IO_EXTENSIONS.
-
-Mon Oct 17 23:49:06 1994 Aubrey Jaffer (jaffer@jacal)
-
- * sys.c (getcwd umask access chmod mkdir rmdir): added
- under IO_EXTENSIONS.
-
- * scm.c (l_pause): added if SIGALRM defined.
- (l_sleep): added if SIGALRM not defined.
-
- * scl.c (num2ulong): added. Used in "time.c"
-
-Sun Oct 16 22:41:04 1994 Aubrey Jaffer (jaffer@jacal)
-
- * sys.c (access chmod): Posix access added under IO_EXTENSIONS.
-
-Fri Oct 14 09:45:32 1994 Aubrey Jaffer (jaffer@jacal)
-
- * posix.c (chown link pipe waitpid, kill, getpw, getgr, get*id,
- set*id): added.
-
- * time.c (l_raise l_getpid): added
- * subr.c (ulong2big):
- * scl.c (ulong2num): useful routines for system call data
- conversion moved from "time.c".
-
-Thu Sep 22 14:48:16 1994 Aubrey Jaffer (jaffer@jacal)
-
- * subr.c (big2inum): (more accruately) renamed from big2long.
-
-Tue Sep 6 22:22:16 1994 Aubrey Jaffer (jaffer@jacal)
-
- From: rshouman@hpcf.cc.utexas.edu (Radey Shouman)
- Date: Mon, 29 Aug 1994 11:36:46 +0600
- * unif.c: This is a large patch, but also a bit larger than it
- appears -- I moved a few function definitions around to eliminate
- gratuitous forward references.
-
- * unif.c repl.c (raprin1): Combined print routine for arrays with
- that for uves.
-
- * unif.c (UNIFORM-VECTOR-READ! and -WRITE): work with general
- arrays, by copying when necessary, renamed them to
- UNIFORM-ARRAY-READ! and -WRITE.
-
- * unif.c (ARRAY-CONTENTS): Generalized so that it returns a 1-d
- array even when the stride in the last dimension is greater than
- one, gave it an optional second argument STRICT, which makes it
- behave as it did before, returning an array/vector only if the
- contents are contiguous in memory.
-
- * unif.c (ARRAY-CONTIGUOUS?) Eliminated. Instead, use
- (lambda (ra) (array? (array-contents ra #t)))
-
- * unif.c code.doc (ramapc): unrolls arrays mapping into one loop
- if possible, to make this quick, changed the format of the array
- CAR, now uses one bit to indicate that an array is contiguous --
- this still allows a ridiculous number of dimensions.
-
- * scm.h (DSUBRF): dsubrs are mapped directly, to allow this I
- moved the typedef for dsubr and #define for DSUBRF to scm.h
-
- * unif.c (ARRAY-MAP!) taught something about subrs, now most subrs
- may be mapped without going through apply(), saving time and
- reducing consing. +, -, *, /, =, <, <=, >, and >= are mapped
- directly as special cases -- for uniform arrays this is nearly as
- fast as the equivalent C, and doesnt' cons. I've made sure that
- +, -, *, and / vectorize on the CRAY, this may be wasted effort
- but the effort is not great.
-
- * unif.c (ARRAY-COPY!) now copies many arrays of differing types
- to each other without going through the aref/aset, e.g. float ->
- double, double -> complex, integer -> float ... This should make
- array type coercions for arithmetic faster.
-
- * unif.c (TRANSPOSE-ARRAY) Added, which returns a shared array
- that is the transpose of its first argument. I think this does
- what an APL:TRANSPOSE would.
-
- * unif.c (ENCLOSE-ARRAY) Added, this returns an array that looks
- like an array of shared arrays, the difference being that the
- shared arrays are not actually allocated until referenced.
- Internally, the contents of an enclosed array is another array.
- The main reason for this is to allow a reasonably efficient
- implementation of APL:COMPRESS, EXPAND, and INDEXING. In order to
- actually make an array of shared arrays, just use ARRAY-COPY!.
-
- * unif.c (cvref): Created internal version of aref(), cvref() that
- doesn't do error checking; Thus speeding things up. Profiling of
- SCM running array code revealed that aref() was taking a
- surprising fraction of the CPU time
-
- TO DO:
-
- The mechanism for looking up the vectorized functions is a little
- kludgy, I was tempted to steal some of the CAR of the subr type to
- encode an offset into a table of vectorized functions, but this
- would make it more likely that dynamically loaded subrs lose thier
- names.
-
- It is almost possible to write APL:+ and friends now, it is just
- necessary to figure out the appropriate type of the returned array
- and allocate it, and to promote scalar arguments to arrays (with
- increments 0).
-
- This doesn't include vectorized REAL-PART, IMAG-PART,
- MAKE-RECTANGULAR ...
-
- I think some C support for APL:REDUCE and maybe INNER-PRODUCT will
- be needed for a reasonably fast APL.scm
-
- unif.c is getting quite big, time to split it up?
-
-
-Mon Sep 5 22:44:50 1994 Aubrey Jaffer (jaffer@jacal)
-
- * Init.scm repl.c (quit): code was not using return values
- correctly.
-
-Sun Aug 21 01:02:48 1994 Aubrey Jaffer (jaffer@jacal)
-
- * record.c (init_record): remaining record functions moved into C
- code.
- * eval.c sys.c: compiled closures now conditional under CCLO.
-
-Sat Aug 20 23:03:36 1994 Aubrey Jaffer (jaffer@jacal)
-
- From: rshouman@chpc.utexas.edu (Radey Shouman)
- * eval.c (ceval apply):
- * sys.c (makcclo): tc7_cclo, compiled closures, now supported.
- * record.c (init_record): C implementation of slib "Record"s using
- CCLO.
- * scm.h subr.c (QUOTIENT MODULO REMAINDER): fixes a bug for
- bignums with DIGSTOOBIG defined. Also, changed the return type of
- longdigs() to void, since that value is no longer used anywhere.
-
-Mon Aug 1 11:16:56 1994 Aubrey Jaffer (jaffer@jacal)
-
- * time.c (curtime): replaces get-universal-time. Other time
- functions removed (SLIB support more complete).
-
- * subr.c (divbigbig): fixed (modulo -2177452800 86400) => 86400
- bug. Also added to test.scm.
-
-Sun Jul 24 16:09:48 1994 Aubrey Jaffer (jaffer@jacal)
-
- * dynl.c (init_dynl): *feature* dld:dyncm added for dynamically
- (ldso) linked libc.sa and libm.sa (under Linux).
-
-Fri Jul 15 12:53:48 1994 Aubrey Jaffer (jaffer@jacal)
-
- * unif.c (array-fill!): bug with increment in default clause fixed.
- Fast string support added.
-
- From: rshouman@chpc.utexas.edu (Radey Shouman)
- * unif.c (array-fill! array-for-each): bug fixes.
-
-Sun Jul 10 01:51:00 1994 Aubrey Jaffer (jaffer@jacal)
-
- * scm.c (run_scm init_scm): "-a" heap allocation argument supported.
-
- * Makefile (proto.h): removed.
-
- From: Drew Whitehouse, Drew.Whitehouse@anu.edu.au
- * scm.h (P): Conditionalized ANSI'fied version of the scm.h.
-
-Sun Jun 26 12:41:59 1994 Aubrey Jaffer (jaffer@jacal)
-
- * Link.scm (usr:lib lib): Now checks for shared libraries
- (lib*.sa) first.
-
-Thu Jun 23 19:45:53 1994 Aubrey Jaffer (jaffer@jacal)
-
- * scl.c scm.c: Support for compilation under Turbo C++ for Windows
- (system and exec disabled) added under C flag "_Windows".
-
-Sat Jun 18 11:47:17 1994 Aubrey Jaffer (jaffer@jacal)
-
- * test.scm ((test-delay)): added.
- ((test-bignum)): added and called automatically if bignums
- suported. test-inexact called automatically if inexacts
- supported.
-
-Mon Jun 6 09:26:35 1994 Aubrey Jaffer (jaffer@jacal)
-
- * Init.scm (trace untrace): moved to SLIB/trace.scm.
-
-Thu May 12 00:01:20 1994 Aubrey Jaffer (jaffer@jacal)
-
- * Link.scm: Autoload for hobbit now does (provide 'hobbit). This
- allows hobbit to know if it is self compiling (although reloads of
- hobbit will not be quite right).
- ((compile file . args)): removed.
-
- * makefile.unix (proto.h): removed.
-
- * Transcen.scm: compile-allnumbers HOBBIT declaration added.
- Init.scm will now load compiled Transcen.o.
-
- * scm.h: HOBBIT section removed.
-
- * README (SLIB): Now strongly recommends getting SLIB and lists
- ftp sites.
-
- * eval.c (m_delay): fixed bug with multiple sets of (delay x).
-
-Thu Apr 28 22:41:41 1994 Aubrey Jaffer (jaffer@jacal)
-
- * unif.c (makflo): shortcut for single precision float arrays
- added.
-
-Fri Apr 15 00:54:14 1994 Aubrey Jaffer (jaffer@jacal)
-
- From: rshouman@chpc.utexas.edu (Radey Shouman)
- * unif.c: no longer uses pointer comparisons in loops. Should
- fix problems on 8086 processors.
- * unif.c (make_sh_array): Fixes MAKE-SHARED-ARRAY so that shared
- arrays with only 1 element in some direction may still be
- ARRAY-CONTIGUOUS?
- (uve_write uve_read): Fixes bug in UNIFORM-ARRAY-WRITE,
- UNIFORM-ARRAY_READ!. Now they do the right thing for shared
- bit-arrays not starting at the beginning of their contents vector.
- (array_contents ARRAY-SIMPLE?): ARRAY-CONTENTS may now return a
- shared, contiguous, 1-d array, instead of a vector, if the array
- cannot access all of the contents vector. ARRAY-SIMPLE? removed.
- (array-fill!): a replacement and generalization of
- UNIFORM-VECTOR-FILL!.
- (raequal): Combines with uve_equal(), providing also ARRAY-EQUAL?
- ARRAY-EQUAL? is equivalent to EQUAL? if all its arguments are
- uniform vectors or if all are arrays. It differs from EQUAL? in
- that a shared, 1-d array may be ARRAY-EQUAL? to a uniform vector.
- for example
- (define sh (make-shared-array '#(0 1 2 3) list '(0 1))) ==> #1(0 1)
- (equal? '#(0 1) sh) ==> #F
- (array-equal? '#(0 1) sh) ==> #T
- (list2ura): Combines list2uve() and list2ura().
-
-Thu Apr 14 23:26:54 1994 Aubrey Jaffer (jaffer@jacal)
-
- * time.c (LACK_FTIME LACK_TIMES): defined for vms.
-
-Mon Apr 4 10:39:47 1994 Aubrey Jaffer (jaffer@jacal)
-
- * eval.c (copytree): now copies vectors as well.
-
- * repl.c (quit): now accepts #t and #f values.
-
-Sun Apr 3 23:30:14 1994 Aubrey Jaffer (jaffer@jacal)
-
- * repl.c (repl): call to my_time() moved to not include READ time.
-
- * time.c (mytime): now prefers to use times() over clock().
- Compilation constant CLOCKS_PER_SEC doesn't scale when a binary is
- moved between machines.
-
-Thu Mar 31 16:22:53 1994 Aubrey Jaffer (jaffer@jacal)
-
- * Init.scm (*SCM-VERSION*): added.
-
- * Makefile (intro): Added message for those who just make.
- Cleaned up and reorganized Makefile.
-
- * patchlvl.h (PATCHLEVEL): removed. Whole version now just in
- SCMVERSION.
-
-Wed Mar 23 00:09:51 1994 Aubrey Jaffer (jaffer@jacal)
-
- From: rshouman@chpc.utexas.edu (Radey Shouman)
- * repl.c (iprin1): Characters higher than 127 print as
- #\<octal-number>.
-
- * Init.scm ((read:array digit port)): added. Most # syntax
- handled in read:sharp.
-
- * unif.c (clist2uve clist2array): removed.
-
-Fri Mar 11 15:10:53 1994 Radey Shouman (rshouman@chpc.utexas.edu)
-
- * sys.c (sfgetc): can now return EOF.
-
-Mon Mar 7 17:07:26 1994 Aubrey Jaffer (jaffer@jacal)
-
- * patchlvl.h (SCMVERSION): 4e0
-
- * scmfig.h: was config.h (too generic).
-
- * scm.c (main run_scm) repl.c (repl_driver init_init): now take
- initpath argument. IMPLINIT now used in scm.c
-
-Sun Feb 27 00:27:45 1994 Aubrey Jaffer (jaffer@jacal)
-
- * eval.c (ceval m_cont IM_CONT): @call-with-current-continuation
- special form for tail recursive call-with-current-continuation
- added. call_cc() routine removed.
-
-Fri Feb 25 01:55:06 1994 Aubrey Jaffer (jaffer@jacal)
-
- * eval.c (ceval m_apply IM_APPLY apply:nconc-to-last): @apply
- special form for tail-recursive apply added. ISYMs reactivated.
-
-Mon Feb 21 14:42:12 1994 Aubrey Jaffer (jaffer@jacal)
-
- * crs.c (nodelay): added. In NODELAY mode WGETCH returns
- eof-object when no input is ready.
-
- * Init.scm ((read:sharp c port)): defined to handle #', #+, and
- #-.
-
- * repl.c (lreadr): Now calls out to Scheme function read:sharp
- when encountering unknown #<char>.
-
-Tue Feb 15 01:08:10 1994 Aubrey Jaffer (jaffer@jacal)
-
- From: Shiro KAWAI <kawai@sail.t.u-tokyo.ac.jp>
- * eval.c (ceval apply): under flag CAUTIOUS, checks for applying
- to non-lists added.
-
-Sat Feb 12 21:23:01 1994 Aubrey Jaffer (jaffer@jacal)
-
- * sys.c (sym2vcell intern sysintern): now use internal strhash().
-
- * scl.c sys.c (hash hashv hashq strhash()): added.
-
-Sat Feb 5 01:24:35 1994 Aubrey Jaffer (jaffer@jacal)
-
- * scm.h (ARRAY_NDIM): #define ARRAY_NDIM NUMDIGS changed to
- #define ARRAY_NDIM(x) NUMDIGS(x) to correct problem on Next.
-
-Fri Feb 4 23:15:21 1994 Aubrey Jaffer (jaffer@jacal)
-
- From: rshouman@chpc.utexas.edu (Radey Shouman)
- * unif.c: 0d arrays added. Serial array mapping functions and
- ARRAY-SIMPLE? added.
-
-Thu Feb 3 12:42:18 1994 Aubrey Jaffer (jaffer@jacal)
-
- * scm.h (LENGTH): now does unsigned shift.
-
-Wed Feb 2 23:40:25 1994 Aubrey Jaffer (jaffer@jacal)
-
- * Link.scm (*catalog*): catalog entries for db (wb),
- turtle-graphics, curses, regex, rev2-procedures, and
- rev3-procedures added.
-
-Sun Jan 30 19:25:24 1994 Aubrey Jaffer (jaffer@jacal)
-
- From: rshouman@chpc.utexas.edu (Radey Shouman)
- * sys.c eval.c setjump.h setjump.s (longjump setjump): full
- continuations now work on Cray YMP.
-
-Thu Jan 27 01:09:13 1994 Aubrey Jaffer (jaffer@jacal)
-
- * dynl.c MANUAL Init.scm (init_dynl): dynamic linking modified for
- modern linux.
-
-Sat Jan 22 17:58:55 1994 Aubrey Jaffer (jaffer@jacal)
-
- From: ucs3028@aberdeen.ac.uk (Al Slater)
- * makefile.acorn repl.c (set_erase): Port to acorn archimedes.
- This uses Huw Rogers free unix function call library for the
- archimedes - this is very very widely available and should pose no
- problem to anyone trying to find it - its on every archimedes ftp
- site.
-
- From: hugh@cosc.canterbury.ac.nz (Hugh Emberson)
- * dynl.c Link.scm: Dynamic Linking with SunOS.
-
-Thu Jan 6 22:12:51 1994 (jaffer at jacal)
-
- * sys.c (gc_mark mark_locations): now externally callable.
-
-Sun Jan 2 19:32:59 1994 (jaffer at jacal)
-
- From: fred@sce.carleton.ca (Fred J Kaudel)
- * unif.c (ra_matchp ramapc): patch to unif.c avoids two problems
- (K&R C does not allow initialization of "automatic" arrays or
- structures). This was not use in 4d2 or previously, and the
- following patch ensures that such initialization only occurs for
- ANSI C compilers (Note that K&R C compilers need to explicitly
- assign the values).
-
-Sat Dec 18 23:55:30 1993 (jaffer at jacal)
-
- * scm.1 scm.doc (FEATURES): improved and updated manual page.
-
- * repl.c (BRACKETS_AS_PARENS): controls whether [ and ] are read
- as ( and ) in forms.
-
-Wed Dec 8 23:13:09 1993 (jaffer at jacal)
-
- From: rshouman@chpc.utexas.edu (Radey Shouman)
- * unif.c: More array fixes and functions.
-
-Tue Dec 7 00:44:23 1993 (jaffer at jacal)
-
- * dynl.c (dld_stub): removed since dld is working better on Linux.
-
-Wed Dec 1 15:27:44 1993 (jaffer at jacal)
-
- * scm.h (SNAME): explicit cast added to get rid of compiler
- warnings.
-
- From: bh@anarres.CS.Berkeley.EDU (Brian Harvey)
- * repl.c (repl) output newlines when more than one form on a line
- for Borland C.
-
- From: rshouman@chpc.utexas.edu (Radey Shouman)
- * unif.c: More array fixes and documentation.
-
-Mon Nov 29 01:06:21 1993 Aubrey Jaffer (jaffer at montreux)
-
- From: rshouman@chpc.utexas.edu (Radey Shouman)
- * unif.c: More array functions (need documentation).
-
-Sun Nov 28 01:34:22 1993 (jaffer at jacal)
-
- * scm.h (SNAME): returns a pointer to nullstr if offset is 0.
-
- * subr.c eval.c (make_synt make_subr): now check that offset from
- heap_org hack works for each subr. If not, 0 is used.
-
- * Link.scm (compile-file): compiles SCM file to object suitable
- for LOAD.
-
- * Link.scm: initialization file created with Scheme code for
- compilation and linking. LOAD now automatically loads SCM object
- files.
-
- * dynl.c Init.scm: dynamic linking now works under DLD on Linux.
- Wb, crs, and sc2 can by dynamically loaded.
-
-Thu Nov 25 22:58:36 1993 (jaffer at jacal)
-
- * sys.c (ltmpnam): return value of mktemp call tested in accord
- with HP-UX documentation (returns "" on error).
-
- * config.h (SYSCALLDEF): removed. Macro I/O calls (getc, putc)
- replaced with function versions. Control-C interrupts should work
- while pending input on all systems again.
-
-Tue Nov 23 01:18:35 1993 (jaffer at jacal)
-
- From: dorai@cs.rice.edu (Dorai Sitaram)
- * repl.c sys.c time.c config.h: MWC (Mark Williams C) support.
-
-Sun Nov 7 10:58:53 1993 (jaffer at jacal)
-
- From: "Greg Wilson" <Greg.Wilson@cs.anu.edu.au>
- * scm.c config.h (TICKS ticks tick-interrupt): if TICKS is
- #defined, ticks and tick-interrupt work like alarm and
- alarm-interrupt, but with units of evaluation rather than units of
- time.
-
-Mon Nov 1 18:47:04 1993 (jaffer at jacal)
-
- * unif.c (uniform-vector-ref => array-ref): integrated arrays
- with uniform-vectors. Strings, vectors, and uniform-vectors
- now just special case of arrays (to the user).
-
-Fri Oct 29 01:26:53 1993 (jaffer at jacal)
-
- * unif.c (rasmob tc16_array): arrays are now a smob.
-
-Thu Oct 28 01:21:43 1993 (jaffer at jacal)
-
- * sys.c repl.c (igc gc_start): GC message gives reason for GC.
-
-Wed Oct 27 10:03:00 1993 (jaffer at jacal)
-
- * config.h (SICP): flag makes (eq? '() '#f) and changes other
- things in order to make SCM more compatible with Abelson and
- Sussman's book.
-
- * sys.c (gc_mark gc_sweep mark_locations): GC bug fixed. GC from
- must_malloc would collect the tc_free_cell already allocated.
-
- * sys.c setjump.h (must_malloc must_realloc INIT_MALLOC_LIMIT):
- modified to call igc when malloc usage exceeds mtrigger (idea from
- hugh@ear.MIT.EDU, Hugh Secker-Walker).
-
- From: Jerry D. Hedden
- * pi.scm (bigpi): bignum version of pi calculator.
-
-Tue Oct 26 18:41:33 1993 (jaffer at jacal)
-
- * repl.c (room): added procedure for printing storage statistics.
-
-Sun Oct 24 22:40:15 1993 (jaffer at jacal)
-
- * config.h eval.c scl.c (STACK_LIMIT CHECK_STACK): added.
- * sys.c (stack_check): added.
-
-Sat Oct 23 00:08:30 1993 (jaffer at jacal)
-
- * sys.c (mallocated): added to keep track of non-heap usage.
-
- * sys.c (igc): fixed interrupt vulnerabilities around gc.
-
-Sun Oct 17 13:06:11 1993 (jaffer at jacal)
-
- * repl.c (exit_report): added. Prints cumulative times if
- (verbose > 2). Called from free_storage().
-
- * repl.c (repl): fixed CRDYP(stdin) BUG! Transcripts should work
- again. Other annoying CR behaviour fixed.
-
- * time.c (init_time your_base my_base): now not reset when
- restarting so timing numbers for restarting are correct.
-
- * scm.h (sys_protects): rearranged.
- * sys.c (tmp_errp): now a statically allocated global variable,
- used by init_storage and free_storage.
- * scm.h sys.c (tc16_fport, tc16_pupe, tc16_strport, tc16_sfport):
- now #defines (which must correspond to order of newptob calls).
-
-Sun Oct 3 20:38:09 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
-
- * README.unix configure configure.in scmconfig.h.in
- mkinstalldirs Makefile.in acconfig-1.5.h: SCM can now be built
- using GNU autoconf. Put in scmconfig4c5.tar.gz
-
-Sun Oct 3 00:33:57 1993 (jaffer at jacal)
-
- * MANUAL (bit-count bit-position bit-set*! bit-count*
- bit-invert!): (from unif.c) are now documented.
-
- * sys.c (fixconfig): added 3rd argument to distinguish between
- setjump.h and config.h.
- * setjump.h config.h: moved IN_SYS stuff from config.h to
- setjump.h.
- * config.h (HAVE_CONFIG_H): User config preferences now taken
- from "scmconfig.h" if HAVE_CONFIG_H is defined.
- * config.h (EXIT_SUCCESS EXIT_FAILURE): fixed for VMS.
-
-Sat Oct 2 00:34:38 1993 (jaffer at jacal)
-
- From: rshouman@hermes.chpc.utexas.edu (Radey Shouman)
- * unif.c repl.c: added read and write syntax for uniform vectors.
- * unif.c (uniform-vector->list list->uniform-vector): created.
- * time.c (time_in_msec): conditionalized for wide range of CLKTCK
- values.
- * config.h (BITSPERDIG POINTERS_MUNGED)
- * scm.h (PTR2SCM SCM2PTR)
- * scl.c (DIGSTOOBIG)
- Ported SCM to Unicos, the Cray operating system.
-
- From: schwab@ls5.informatik.uni-dortmund.de (Andreas Schwab)
- * scl.c (dblprec): set from DBL_DIG, if available.
-
-Fri Oct 1 21:43:58 1993 (jaffer at jacal)
-
- * unif.c (bit-position): now returns #f when item is not found.
- Now returns #f when 3rd argument is length of 2nd argument
- (instead of error).
-
-Fri Sep 24 14:30:47 1993 (jaffer at jacal)
-
- * sys.c (free_storage): fixed bug where growth_mon was being
- called after the port cell had been freed. gc_end now also
- called at end.
-
-Tue Sep 21 23:46:05 1993 (jaffer at jacal)
-
- * Init.scm scm.c: Restored old command line behaviour (loading all
- command line arguments) for case when first command line argument
- does not have leading `-'.
-
- * sys.c (mode_bits): abstracted from open_file and mksfpt.
-
- * scm.h (*FPORTP): series of predicates added for operations which
- only work on some fports.
-
- * sys.c crs.c: ungetc removed from ptobfuns structure and
- soft-ports.
-
-Mon Sep 20 23:53:25 1993 (jaffer at jacal)
-
- * sys.c (make-soft-port): Soft-ports added, allowing Scheme
- i/o extensions.
-
-Sun Sep 19 22:55:28 1993 (jaffer at jacal)
-
- * 4c4: released.
- * Init.scm scm.c scm.1: command line proccessing totally
- rewritten. Thanks to Scott Schwartz
- <schwartz@groucho.cs.psu.edu> for help with this.
-
-Mon Sep 13 21:45:52 1993 (jaffer at jacal)
-
- From: pegelow@moorea.uni-muenster.de (Ulrich Pegelow)
- * scl.c (add1): finally a way to fool optimizing gcc to not use
- extra precision registers.
-
-Sun Sep 12 18:46:02 1993 (jaffer at jacal)
-
- * sys.c (pwrite): added to stubbify fwrite to fix bug on VMS.
- * config.h: moved flags to top per suggestions from Bryan
- O'Sullivan (bos@scrg.cs.tcd.ie).
-
-Fri Sep 10 11:42:27 1993 (jaffer at jacal)
-
- * repl.c config.h (EXIT_SUCCESS EXIT_ERROR): added. Values
- returned by SCM program.
-
-Thu Sep 9 13:09:28 1993 Aubrey Jaffer (jaffer at camelot)
-
- From: Vincent Manis <manis@cs.ubc.ca>
- * sys.c (stwrite init_types add_final): fixed declarations.
-
-Mon Sep 6 16:10:50 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
-
- * README: changed the build and installation instructions to bring
- them up to date with reality.
-
-Sun Sep 5 23:08:54 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
-
- * Wrote autoconf script to support GNU Autoconf configuration
- to make scm easier to build.
-
- * Created Makefile.in; a radical overhaul of Makefile to remove
- some of the brokenness and allow cross-compilation and use of
- autoconf.
-
-Sat Sep 4 23:00:49 1993 (jaffer at jacal)
-
- * 4c3: released.
- * sys.c (grow_throw): removed use of memset for SPARC machines.
-
-Sat Sep 4 18:09:59 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
-
- * time.c: added SVR4 to the list of LACK_FTIME systems, because
- most all SVR4 BSD-compatibility stuff is a total mess.
-
- * config.h: changed definition of STDC_HEADERS so it does the
- Right Thing on systems which run GCC but don't have header files
- with prototypes.
-
- * makefile.unix: added a note for SVR4 users.
-
-Tue Aug 31 18:30:53 1993 (jaffer at jacal)
-
- * eval.c (m_define): if verbose >= 5 warnings are issued for all
- top-level redefinitions.
-
-Mon Aug 30 16:24:26 1993 (jaffer at jacal)
-
- * scm.c sys.c (finals num_finals add_final): Finalization calls
- now dynamically, incrementally, defined.
-
-Thu Aug 26 12:38:27 1993 Aubrey Jaffer (jaffer at camelot)
-
- * 4c2: fixed declaration problems in PTOB with K&R C.
-
-Sun Aug 22 23:02:51 1993 (jaffer at jacal)
-
- * split.scm: code which directs input, output, and diagnostic
- output to separate windows (using curses functions defined in
- crs.c).
-
-Sat Aug 21 16:46:33 1993 (jaffer at jacal)
-
- * Init.scm (output-port-height): added if not already defined.
- output-port-width also made conditional.
-
- * sys.c (tc16_strport): string ports created.
-
-Thu Aug 19 11:37:07 1993 (jaffer at jacal)
-
- * sys.c (init_types): freecell, floats, and bignums now have SMOB
- entries. gc_sweep and gc_mark still inline codes for bignums and
- floats.
-
- * sys.c repl.c code.doc: Ports now an extensible type.
- Indirection suggested by Shen <sls@aero.org>.
-
-Mon Aug 16 01:20:26 1993 (jaffer at jacal)
-
- * crs.c: curses support created.
-
-Sun Aug 15 16:56:36 1993 (jaffer at jacal)
-
- * rgx.c sys.c (mark0 equal0): mark0 moved to sys.c. equal0
- created.
-
-Fri Jun 25 01:16:31 1993 (jaffer at jacal)
-
- * QUICKREF: added.
-
-Tue Jun 22 00:40:58 1993 Aubrey Jaffer (jaffer at camelot)
-
- * repl.c (ungetted): replaced with CRDYP(stdin) to fix recently
- introduced transcript bug.
-
-Sun Jun 20 22:29:32 1993 Aubrey Jaffer (jaffer at camelot)
-
- * config.h (NOSETBUF): setbuf() now conditionalized on NOSETBUF.
-
- * Init.scm (defmacro): now copies the results of macro expansion
- in order to avoid capture of memoized code by macros like:
- (defmacro f (x) `(list '= ',x ,x)).
-
-Wed Jun 2 23:32:05 1993 Aubrey Jaffer (jaffer at caddr)
-
- * eval.c (map for-each): now check that arguments are lists.
-
-Mon May 31 23:05:19 1993 Aubrey Jaffer (jaffer at camelot)
-
- * Init.scm (trace untrace): now defmacros which handle (trace) and
- (untrace) as in Common Lisp.
-
-Wed May 5 01:17:37 1993 Aubrey Jaffer (jaffer at camelot)
-
- From: Roland Orre <orre@sans.kth.se>
- * all: internal output functions now take SCM ports instead of
- FILE* in preparation for string-ports.
-
-Tue May 4 17:49:49 1993 Aubrey Jaffer (jaffer at wbtree)
-
- * makefile.unix (escm.a): created scm "ar" file and used for
- dbscm.
-
-Sun Apr 25 21:35:46 1993 Aubrey Jaffer (jaffer at camelot)
-
- * sys.c (free_storage): i++ moved out of CELL_* in response to:
-From: john kozak <jkozak@cix.compulink.co.uk>
-Minor bug report: around line 10 of routine "free_storage" you do calls
-to CELL_UP and CELL_DOWN with arguments having side-effects: with the
-PROT386switch defined in config.h these args are evaluated twice...
-
-Sun Apr 11 22:56:19 1993 Aubrey Jaffer (jaffer at camelot)
-
- * eval.c (IM_DEFINE): added. Internal defines are no longer
- turned into LETRECS.
-
-Wed Apr 7 13:32:53 1993 Aubrey Jaffer (jaffer at camelot)
-
- Jerry D. Hedden <HEDDEN@ESDSDF.dnet.ge.com>
- * scl.c (idbl2str): fix for bug introduced by removing +'s.
-
-Tue Mar 23 15:37:12 1993 Aubrey Jaffer (jaffer at camelot)
-
- * scl.c (idbl2str): now prints positivie infinity as +#.# again
- (instead of #.#).
-
-Mon Mar 22 01:38:02 1993 Aubrey Jaffer (jaffer at montreux)
-
- * subr.c (quotient): renamed to lquotient to avoid conflict with
- HP-UX 9.01.
-
-Fri Mar 19 01:21:08 1993 Aubrey Jaffer (jaffer at camelot)
-
- * sys.c repl.c: #ifndef THINK_C #include <sys/ioctl.h>
- * time.c (lstat): #ifndef THINK_C. ThinkC 5.0.1 lacked.
-
-Mon Mar 15 23:35:32 1993 Aubrey Jaffer (jaffer at camelot)
-
- From: jhowland@ariel.cs.trinity.edu (Dr. John E. Howland)
- * scl.c (idbl2str iflo2str big2str): leading + eliminated on
- output and number->string.
-
-Wed Mar 10 00:58:32 1993 Aubrey Jaffer (jaffer at camelot)
-
- * repl.c scm.h (CRDYP CLRDY CGETUN CUNGET): cleaned up ungetc hack.
-
- * scm.c repl.c (exec): added.
-
-Sun Mar 7 22:44:23 1993 Aubrey Jaffer (jaffer at camelot)
-
- * repl.c (def_err_response): now will print errobjs if they are
- immediates, symbols, ports, procedures, or numbers.
-
-Fri Mar 5 23:15:54 1993 Aubrey Jaffer (jaffer at camelot)
-
- * repl.c (repl): now gives repl_report() for initialization.
-
- * Init.scm (defvar): added.
-
- From: Roland Orre <orre@sans.kth.se>
- * repl.c (lungetc): no longer calls ungetc. Fixed problem that
- many systems had with ungetc on unbuffered ports (setbuf(0)).
-
-Thu Mar 4 13:51:12 1993 Aubrey Jaffer (jaffer at camelot)
-
- From: Stephen Schissler
- * makefile.wcc: Watcom support added.
-
-Wed Mar 3 23:11:08 1993 Aubrey Jaffer (jaffer at montreux)
-
- * sys.c scm.h (dynwinds): made a sys_protect.
-
-Mon Feb 15 11:30:50 1993 Aubrey Jaffer (jaffer at camelot)
-
- * Init.scm (defmacro macroexpand macroexpand1 macro? gensym):
- added.
-
- * repl.c (stdin): setbuf not done for __TURBOC__==1.
-
- * makefile.bor: now has method to build turtegr.exe.
-
- * eval.c (ceval): Memoizing macros now can return any legal Scheme
- expression.
-
-Sat Feb 13 18:01:13 1993 Aubrey Jaffer (jaffer at camelot)
-
- * subr.c (mkbig adjbig): now check for bignum size.
-
- * Init.scm: reorganized so site-specific information is at the
- head.
-
- * repl.c (errno): changed from set-errno now returns value.
-
- * subr.c (intexpt): now handles bignum exponents.
-
- From: "David J. Fiander" <davidf@golem.waterloo.on.ca>
- * time.c makefile.unix subr.c: SCO Unix and XENIX patches.
-
-Fri Feb 12 22:18:57 1993 Aubrey Jaffer (jaffer at camelot)
-
- * Init.scm (WITH-INPUT-FROM-PORT WITH-OUTPUT-TO-PORT
- WITH-ERROR-TO-PORT): added.
-
- * subr.c (ash): fixed for case (ash 2 40) where INUM arguments
- make a bignum result.
-
- * repl.c (lreadr): \ followed by a newline in a string is ignored.
-
- From: Scott Schwartz <schwartz@groucho.cs.psu.edu>
- * repl.c (lreadr): Can now read \0\f\n\r\t\a\v in strings.
-
-Thu Feb 11 01:25:50 1993 Aubrey Jaffer (jaffer at camelot)
-
- * Init.scm (with-input-from-file with-output-to-file
- with-error-to-file): now use dynamic-wind.
-
-Sun Feb 7 22:51:08 1993 Aubrey Jaffer (jaffer at camelot)
-
- * eval.c (ceval): fixed bug with non-memoizing macro returning an
- IMP.
-
-Sat Feb 6 01:22:27 1993 Aubrey Jaffer (jaffer at camelot)
-
- * (current-error-port with-error-to-file): add.
-
-Fri Feb 5 00:51:23 1993 Aubrey Jaffer (jaffer at camelot)
-
- * time.c (stat): added.
-
- From: rnelson@wsuaix.csc.wsu.edu (roger nelson)
- * dmakefile: support for DICE C on Amiga.
-
-Thu Feb 4 01:55:30 1993 Aubrey Jaffer (jaffer at camelot)
-
- * sys.c (open-file) makes unbuffered if isatty.
-
- * repl.c (char-ready?) added.
-
-Mon Feb 1 15:24:18 1993 Aubrey Jaffer (jaffer at camelot)
-
- * subr.c (logor): changed to LOGIOR to be compatible with common
- Lisp.
-
- * eval.c (bodycheck): now checks for empty bodies.
-
-Sun Jan 31 01:01:11 1993 Aubrey Jaffer (jaffer at camelot)
-
- * time.c (get-universal-time decode-universal-time): now use
- bignums.
-
-Tue Jan 26 00:17:06 1993 Aubrey Jaffer (jaffer at camelot)
-
- * sys.c (mark_locations): now length argument in terms of
- STACKITEM. Does both alignments in one pass.
-
-Mon Jan 25 12:13:40 1993 Aubrey Jaffer (jaffer at camelot)
-
- From: soravi@Athena.MIT.EDU
- * makefile.emx: for OS/2
-
-Sun Jan 24 18:46:32 1993 Aubrey Jaffer (jaffer at camelot)
-
- From: stevev@miser.uoregon.edu (Steve VanDevender)
- * scl.c (big2str): now faster because it divides by as many 10s as
- fit in a BIGDIG.
-
-Sat Jan 23 00:23:53 1993 Aubrey Jaffer (jaffer at camelot)
-
- From: stevev@miser.uoregon.edu (Steve VanDevender):
- * config.h (INUM MAKINUM): shift optimization for TURBOC.
-
-Fri Jan 22 00:46:58 1993 Aubrey Jaffer (jaffer at montreux)
-
- From: hanche@ams.sunysb.edu (Harald Hanche-Olsen)
- * unif.c (uniform-vector?): added.
-
-Tue Jan 19 00:27:04 1993 Aubrey Jaffer (jaffer at camelot)
-
- From: stevev@miser.uoregon.edu (Steve VanDevender)
- * subr.c scl.c config.h: bignum bug fixes for MSDOS.
-
-Mon Jan 18 01:15:24 1993 Aubrey Jaffer (jaffer at camelot)
-
- * subr.c (ash lognot intlength logcount bitextract): now handle
- bignums.
-
-Sun Jan 17 10:42:44 1993 Aubrey Jaffer (jaffer at camelot)
-
- * sys.c (close_port): can now close pipes as well.
-
- * subr.c (adjbig normbig divide quotient): fixed more divide bugs.
-
- * subr.c (even? odd?): fixed problem with bignums.
-
-Sat Jan 16 00:02:05 1993 Aubrey Jaffer (jaffer at camelot)
-
- * subr.c (divbigbig): Fixed last divide bug?
-
-Fri Jan 15 00:07:27 1993 Aubrey Jaffer (jaffer at camelot)
-
- * rgx.c (regmatch?): added. Debugged for both HP-UX and GNU
- regex-0.11. Documentation added to MANUAL.
-
-Thu Jan 14 11:54:52 1993 Aubrey Jaffer (jaffer at camelot)
-
- * patchlvl.h (SCMVERSION): moved from config.h.
-
- * scl.c (product): fixed missing {} bug.
-
- From: HEDDEN@esdsdf.dnet.ge.com
- * scl.c (lmin lmax) bignum versions.
-
-Wed Jan 13 01:40:51 1993 Aubrey Jaffer (jaffer at camelot)
-
- * released scm4b0.
-
- * subr.c: fixed bignum bugs found by jacal.
-
- * code cleanup.
-
- From: HEDDEN@esdsdf.dnet.ge.com
- * subr.c (lgcd quotent modulo lremainder): Bignum versions.
- * subr.c (divbigbig): new version.
-
-Sun Jan 3 00:29:35 1993 Aubrey Jaffer (jaffer at camelot)
-
- From: stevev@miser.uoregon.edu (Steve VanDevender)
- * Re-port to BorlandC v2.0
-
- * sys.c (must_realloc): added
-
- * config.h subr.c (BIGRAD pseudolong): now insensitive to ratio of
- sizeof(long)/sizeof(BIGDIG).
-
-Mon Dec 21 23:20:47 1992 Aubrey Jaffer (jaffer at camelot)
-
- From: Scott Schwartz <schwartz@groucho.cs.psu.edu>
- * rgx.c: created SCM interface to regex and regexp routines.
-
- From: HEDDEN@esdsdf.dnet.ge.com
- * subr.c scl.c: Now just one mulbigbig and addbigbig routine.
-
- from: soravi@Athena.MIT.EDU
- * README: directions for compiling SCM under OS/2 2.0.
-
-Wed Dec 9 15:34:30 1992 Aubrey Jaffer (jaffer at camelot)
-
- * eval.c (tc7_subr_2x): eliminated. All comparison subrs now
- rpsubrs.
-
- * scm.h: Changed SUBR numbers. This improves HP-UX interpretation
- speed (why?).
-
- * eval.c (PURE_FUNCTIONAL): removed. Can now be done in
- initialization code.
-
- * eval.c (tc7_rpsubr): added type for transitive comparison
- operators. Suprisingly, this slows down (pi 100 5).
-
-Mon Dec 7 16:15:47 1992 Aubrey Jaffer (jaffer at camelot)
-
- * subr.c (logand logor logxor lognot ash logcount integer-length
- bit-extract): added.
-
- From: HEDDEN@esdsdf.dnet.ge.com
- * scl.c: lots more numeric improvements and code reductions.
-
-Mon Nov 30 12:25:54 1992 Aubrey Jaffer (jaffer at camelot)
-
- * scm.h (IDINC ICDR IDIST): enlarged depth count in ILOCs.
-
-Sun Nov 29 01:10:18 1992 Aubrey Jaffer (jaffer at camelot)
-
- * subr.c scl.c: most arithmetic operations will now return
- bignums.
-
- * config.h (FIXABLE POSFIXABLE NEGFIXABLE): added.
-
- * sys.c (object-hash object-unhash): now use bignums.
-
- * scl.c (big2str istr2int): bignum i/o implemented.
-
- * unif.c: subr2s were incorrectly initialized as lsubr2s.
-
-Tue Nov 24 14:02:52 1992 Aubrey Jaffer (jaffer at camelot)
-
- * eval.c (ceval): added unmemocar calls to error handling when
- possible.
-
- * scl.c (idbl2str): added back NAN and infinity support.
-
- * eval.c (syntax_mem): replaced with individual macros.
- * eval.c (procedure->syntax procedure->macro
- procedure->memoizing-macro): All syntactic keywords are now
- tc7_symbol. User definable macros added.
- * sys.c: ISYMs no longer in symhash. ISYMs cannot be read.
- init_isyms merged into init_eval.
-
-Sat Nov 21 00:39:31 1992 Aubrey Jaffer (jaffer at camelot)
-
- * makefile.unix (check): now exits with error code.
-
- * sys.c (init_isyms): eliminated. ISYMS now inited in init_eval.
-
-Fri Nov 20 16:14:06 1992 Aubrey Jaffer (jaffer at camelot)
-
- * released scm4a13
-
- * repl.c: longjmps now dowinds() first.
-
- * setjump.h: now has all setjmp related definitions.
-
- * Init.scm (trace untrace): use new macro system.
-
- * eval.c (defined? procedure->macro procedure->memoizing-macro
- make_synt): macro system added. defined? uses it.
-
- From: HEDDEN@esdsdf.dnet.ge.com
- * scl.c: fixes for several transcendental functions.
-
-Thu Nov 19 01:14:38 1992 Aubrey Jaffer (jaffer at camelot)
-
- * repl.c sys.c: errjmp replaced with JMPBUF(rootcont).
-
-Sun Nov 15 01:49:00 1992 Aubrey Jaffer (jaffer at camelot)
-
- From: HEDDEN@esdsdf.dnet.ge.com
- * scl.c (istr2int istr2flo istring2number string2number): new
- versions.
-
-Thu Nov 12 23:00:04 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * Init.scm (load): now prints out actual filename found in mesasge
- ;done loading ...
-
-Wed Nov 11 01:01:59 1992 Aubrey Jaffer (jaffer at camelot)
-
- * repl.c (def_err_response): ARG1 error with errobj==UNDEFINED
- becomes WNA error.
-
- From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden)
- * scl.c (difference divide): Now are asubrs.
-
- * Init.scm (*features*): fixed to correspond to SLIB conventions.
-
-Mon Nov 9 12:03:58 1992 Aubrey Jaffer (jaffer at camelot)
-
- * scl.h test.scm: (string->number "i") and "3I" and "3.3I" fixed
- to return #f. Tests added to test.scm.
-
-Fri Nov 6 16:39:38 1992 Aubrey Jaffer (jaffer at camelot)
-
- * scm.h (rootcont): sysprotect added.
-
- From: Vincent Manis <manis@cs.ubc.ca>
- * scm.h: __cplusplus prototype support.
-
-Thu Nov 5 00:39:50 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * eval.c (lookupcar): now checks for UNDEFINED in local bindings
- becuase LETREC inits to UNDEFINED.
-
- * sys.c (dynamic-wind): added.
-
- * config.h eval.c (ceval): CAUTIOUS mode added.
-
- From: hugh@ear.MIT.EDU (Hugh Secker-Walker)
- * eval.c (ceval): internal defines now transformed to letrecs.
-
-Sun Oct 25 12:27:23 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * repl.c (read-line read-line!): created.
-
-Sat Oct 24 18:36:23 1992 Aubrey Jaffer (jaffer at camelot)
-
- * repl.c (lreadparen): now tail-recursive.
-
- * eval.c (copy-tree eval): added. dummy_cell replaced with a
- cons(obj,UNDEFINED).
-
-Thu Oct 22 21:26:53 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * repl.c (set-errno!): changed to set-errno.
-
-Thu Oct 15 00:49:20 1992 Aubrey Jaffer (jaffer at camelot)
-
- * sys.c (must_free): must_free created. Pointers are set to 0.
- It detects objects being freed twice.
-
-Wed Oct 14 23:57:43 1992 Aubrey Jaffer (jaffer at camelot)
-
- * scm.c (run_scm): Now has INITS and FINALS.
-
- * scm.c (init_signals ignore_signals unignore_signals
- restore_signals): siginterrupt() for ultix.
-
-Fri Oct 9 14:25:06 1992 Aubrey Jaffer (jaffer at camelot)
-
- * all: put in explicit casts to (unsigned char *) and (long) to
- satisfy lint.
-
- * sys.c (gc): all to gc_end was during deferred interrupts,
- causing problems with verbose=3 and interrupts during GC.
-
- * config.h(SYSCALLDEF): fixed so that test on errno occurs before
- ALLOW_INTS (and possible call to user code).
-
-Sun Oct 4 01:45:25 1992 Aubrey Jaffer (jaffer at camelot)
-
- * eval.c (syntax_mem): removed gratuitous cons.
-
- * eval.c repl.c scm.h: Reduced static string use. Added peephole
- optimizations for AND and OR.
-
- From: hugh@ear.MIT.EDU (Hugh Secker-Walker)
- * eval.c repl.c scm.h (syntax_mem): syntax forms are now memoized
- so that syntax checks are done only once. Interpreter is now
- smaller and faster and uses less stack space. Modifications to
- code are now made under DEFER_INTS as they always should have
- been.
-
-Wed Sep 30 22:06:24 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * scl.c subr.c scm.h config.h: Started adding bignum code.
-
-Sun Sep 27 22:59:59 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * repl.c (restart): added.
-
- * sys.c (freeall): finished.
-
- * scm.h (tc7_symbol): split into tc7_ssymbol and tc7_msymbol to
- distinguish between non-GCable and GCable symbols.
-
-Wed Sep 23 00:36:23 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * repl.c (peek_char lungetc): added workaround for TURBOC 1.0
- problem with ungetc inside SYSCALLDEF macro.
-
- * repl.c (iprin1): uses ttyname for #<stream ..> if available.
-
- * Init.scm: now sets verbose to 0 if stdin or stdout is not a tty.
-
- * repl.c (isatty?): added.
-
- * repl.c (verbose): levels bumped up by 1. verbose == 0 means no
- prompt.
-
- * makefile.djg config.h (GNUDOS -> GO32): flags changed for djgpp108.
-
-Wed Aug 26 21:46:26 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * test.scm: put in (test #f < 1 3 2) and (test #f >= 1 3 2).
-
- * scl.c (leqp greqp): put back in. (not (< 1 3 2)) does not imply
- (>= 1 3 2).
-
- * makefile.unix: tar and shar files now created in subdirectory.
-
- * config.h time.c: Linux support added.
-
- * repl.c: Greatly improved VMS interrupt support.
-
- * eval.c (ceval): I_LET now changes to I_LETSTAR for single clause
- unnamed lets.y
-
- * (tc7_lsubr_2n): removed.
-
-Fri Jul 31 00:24:50 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * unif.c (bit-position): fixed; I am sure I had done these
- changes before. Also corrected some error messages.
-
- From: campbell@redsox.bsw.com (Larry Campbell)
- * scm.h subr.c sys.c (equalp): smobfuns now include equalp.
-
-Mon Jul 20 16:44:30 1992 Aubrey Jaffer (jaffer at Ivan)
-
- From: Stephen Adams <S.R.Adams@ecs.southampton.ac.uk>
- * eval.c scm.h subr.c (BOOL_NOT) macro added to fix ^ bug in
- BorlandC. This was fixed previously as well.
-
- From: campbell@redsox.bsw.com (Larry Campbell)
- * unif.c (vector-set-length!): was always typing to tc7_vector.
-
-Sat Jul 18 01:07:33 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * subr.c sys.c (make_vector init_storage resizuve): mallocs and
- reallocs are now always > 0.
-
- * time.c (get_univ_time): bypassed mktime() for (__TURBOC__ == 1).
-
-Mon Jul 13 22:27:04 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * repl.c (lreadr): now ignores first line of port if begins with "#!"
-
- * scl.c (lesseqp greqp): removed; changed to use tc7_lsubr_2n.
-
- * scm.h eval.c (tc7_lsubr_2n): type added. Other subr types
- rearranged.
-
-Sat Jul 11 23:47:18 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * scm.h sys.c repl.c eval.c code.doc (newsmob smobs smobfuns): now
- support dynamically added smob types. Promises moved to eval.c.
- Promises and arbiters are now newsmobs.
-
- * makefile.unix repl.c scl.c (floprint): moved from repl.c to
- scl.c. The only files which care about -DFLOATS are now scl.c,
- eval.c, scm.c, and unif.c.
-
- * sys.c scm.h (init_storage): now uses variable num_protects
- instead of #define NUM_PROTECTS.
-
-Tue Jul 7 00:00:57 1992 Aubrey Jaffer (jaffer at Ivan)
-
- From: Ulf_Moeller@hh2.maus.de (Ulf Moeller)
- * Init.scm config.h makefile.prj: support for the ATARI-ST with
- Turbo C added.
-
-Tue Jun 30 23:45:50 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * unif.c (make-uniform-vector uniform-vector-set!
- uniform-vector-ref): added.
-
-Tue Jun 23 11:49:13 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * scm.h sys.c code.doc: rearranged tc7 codes and added bvect,
- ivect, uvect, fvect, dvect, cvect, and cclo.
-
- * scm.h sys.c eval.c repl.c code.doc: Changed symbols to be
- tc7_symbol.
-
-Sat Jun 6 22:27:40 1992 Aubrey Jaffer (jaffer at Ivan)
-
- From: campbell@redsox.bsw.com (Larry Campbell)
- * scl.c (divide): divide by 0 and Exact-only divides of non
- multiples now cause exception in RECKLESS mode.
-
-Wed May 27 16:02:58 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * config.h scl.c (NUMBUFLEN): split into INTBUFLEN and FLOBUFLEN
- and made proportional to size of numeric types.
-
- From: fred@sce.carleton.ca (Fred J Kaudel)
- * makefile.ast scm.c Init.scm: minor chages for ATARI ST support.
-
- * test.scm (test-inexact): created.
-
-Thu May 21 11:43:41 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h (PATCHLEVEL): 5
-
- From: hugh@ear.mit.edu (Hugh Secker-Walker)
- * config.h: better wording for heap allocation strategy
- explanation.
-
-Wed May 20 00:31:18 1992 Aubrey Jaffer (jaffer at Ivan)
-
- From S.R.Adams@ecs.southampton.ac.uk
- * subr.c (stci_leqp st_leqp): reversed order of ^ clauses to avoid
- Borland 3.0 bug.
-
- * sys.c (gc_sweep): missing i-=2; added when splicing out segment.
-
- * MANUAL time.c (get-universal-time decode-universal-time): half
- hearted attempt to add these. Needs bignums.
-
-Wed May 13 14:01:07 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c (gc_mark): improved tail recursivness for CONSes.
-
- * repl.c (growth_mon): now prints out the hplims table if
- verbose>3.
-
- * sys.c (init_heap_seg): Serious bug in growing hplims fixed.
- num_heap_segs eliminated; hplims are realloced whenever grown.
-
-Tue May 12 15:36:17 1992 Aubrey Jaffer (jaffer at train)
-
- * config.h sys.c (alloc_some_heap expmem): expmem captures
- whether the INIT_HEAP_SIZE allocation was successful. If so,
- alloc_some_heap uses exponential heap allocation instead of
- HEAP_SEG_SIZE.
-
-Mon May 11 15:29:04 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c (gc_sweep init_heap_seg heap_org): Empty heap segments
- are now freed.
-
- * sc2.c (STR_EXTENSIONS): renamed REV2_PROCEDURES and R2RS and
- R3RS functions put into sc2.c.
-
-Sun May 10 01:34:11 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * scm.c (ignore_interrupts unignore_interrupts): added for
- system, edt$edit, and popen to use.
-
- * repl.c (lwrite display newline write_char): Close pipe if EPIPE.
-
- * repl.c (file_set_position): now errs on ESPIPE.
-
- * scm.c (SIGPIPE): now ignored (errs come back as EPIPE).
-
-Sat May 9 17:52:36 1992 Aubrey Jaffer (jaffer at Ivan)
-
- From: Stephen Adams <S.R.Adams@ecs.southampton.ac.uk>
- * config.h (PROT386): PROT386 added. PTR_LT and CELL_UP modified.
-
-Fri May 8 17:57:22 1992 Aubrey Jaffer (jaffer at Ivan)
-
- From: hugh@ear.mit.edu (Hugh Secker-Walker)
- * Init.scm (last-pair append!): last-pair is faster version.
- Append! corrected for null first arg. (getenv "HOME") now gets
- a "/" added if not present.
-
- * config.scm (MIN_GC_YIELD): now proportional to HEAP_SEG_SIZE.
-
- * README: setting environment variables corrected.
-
- * subr.c (length): error message now has arg if not a list.
-
- * sys.c (open-pipe): now turns off interrupts before forking.
-
- * scl.c (lsystem): now turns off interrupts before forking.
-
- * scm.c (ignore_signals): created.
-
-Sat May 2 01:02:16 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * Init.c (WITH-INPUT-FROM-FILE WITH-OUTPUT-TO-FILE): defined in
- terms of current-input-port and current-output-port. Bug in
- open-input-pipe and open-output-pipe fixed.
-
- * sys.c repl.c (current-input-port current-output-port): moved
- from sys.c to repl.c. set-current-input-port and
- set-current-output-port added to repl.c.
-
-Mon Apr 13 22:51:32 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h: (PATCHLEVEL): released scm4a1.
-
- * makefile.* VMSBUILD.COM VMSGCC.COM: compile time.h.
-
- * scm.c (alrm_signal int_signal): now save and restore errno so
- SYSCALL will work correctly across interrupts.
-
-Sun Apr 12 01:44:10 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h: (PATCHLEVEL): released scm4a0.
-
- * repl.c (lread): tok_buf now local to each invocation of read.
- This makes READ interruptable and reentrant.
-
- * sys.c MANUAL (STRING-SET-LENGTH! STRING-VECTOR-LENGTH!): created.
-
- * sys.c repl.c (grow_tok_buf tok_buf tok_buf_len): moved to repl.c
-
- * repl.c (lfwrite): now emulated for VMS.
-
- * repl.c scl.c (num_buf): now local to all routines that use it.
-
- * time.h: created by moving time functions from repl.c. Read and
- write functions were moved from sys.c to repl.c.
-
- * sys.c repl.c (DEFER_INTS ALLOW_INTS CHECK_INTS): totally
- rewritten. SIGALRM and SIGINT now execute at interrupt level.
- Interrupts deferred only for protected code sections, not for
- reads and writes.
-
- * sys.c repl.c (SYSCALL): created to reexecute system calls
- interrupted (EINTR) by SIGALRM and SIGINT.
-
- * sys.c scl.c (flo0): 0.0 is now always flo0.
-
- * repl.c sys.c (TRANSCRIPT-ON TRANSCRIPT-OFF): added. This
- required shadowing putc, fputs, fwrite, and getc with lputc,
- lputs, lfwrite, and lgetc.
-
-Sun Apr 5 00:27:33 1992 Aubrey Jaffer (jaffer at Ivan)
-
- From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden)
- * scl.c (eqp lessp greaterp lesseqp greatereqp):
- Comparisons with inexact numbers was not being performed
- correctly. For example, (< 1.0 2.0 1.5) would yield #t. What was
- missing was a line x=y; in the inexact comparison sections of
- lessp(), greaterp(), lesseqp() and greatereqp(). In addition, I
- modified these routines and eqp() to allow for mixed arithmetic
- types.
-
-Sat Apr 4 00:17:29 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * scm.h code.doc: tc7_bignum => tc7_spare. Added tc16_bigpos and
- tc16_bigneg. SMOBS reordered. tc16_record added.
-
- * scm.h repl.c sys.c (make-arbiter try-arbiter release-arbiter):
- added. tc16_arbiter added.
-
-Fri Apr 3 01:25:35 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c config.h (TEMPTEMPLATE): created in config.h.
-
- * scm.h: removed long aliases for C versions of Scheme functions.
-
- * sys.c eval.c scm.h: (delay force makprom): added. Also added
- tc16_promise data type.
-
- * Init.scm (trace untrace): added autoloads and read macros.
-
- From: T. Kurt Bond, tkb@mtnet2.wvnet.edu
- * sys.c (template): correct template for VMS.
-
-Tue Mar 31 01:50:12 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c config.h Init.scm (open-file open-pipe): created and
- expressed other open functions in terms of. Bracketed all i/o
- system calls with DEFER and ALLOW _SIGINTS.
-
-Sat Mar 28 00:24:01 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c MANUAL (#.): read macro syntax added. Balanced comments
- also documented.
-
-Fri Mar 27 22:53:26 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c (iprin1): changed printed representation for unreadable
- objects from #[...] to #<...>.
-
- From: brh@aquila.ahse.cdc.com (brian r hanson x6009):
- * scm.h config.h (NCELLP PTR_LT): fixes for 64 bit pointers on
- nosve.
-
-Fri Mar 20 01:36:08 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * Released scm3c13
-
- * code.doc: corrected some minor inconsistencies and added a
- section "To add a package of new procedures to scm".
-
-Sun Mar 15 19:44:45 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * Init.scm: now loads <program-name>_INIT_PATH when <program-name>
- is not "SCM".
-
- * config.h (PTR_LT): (x < y) => ((x) < (y))
-
-Wed Mar 4 01:53:15 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * Released scm3c12.
-
- * scm.h code.doc eval.c sys.c (IXSYM): Eliminated Immediate IXSYM
- type.
-
-Tue Mar 3 00:58:18 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * eval.c config.c (ceval DEFINED? SYNTAX_EXTENSIONS): added
- DEFINED? to ceval conditional on SYNTAX_EXTENSIONS.
-
- From: Andrew Wilcox <andrew@astro.psu.edu>
- * makefile.unix scm.c (main init_scm display_banner init_signals
- restore_signals run_scm): RTL support.
-
-Mon Mar 2 19:05:29 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * subr.c (make-string): now checks for ARG1 >= 0.
-
-Fri Feb 28 00:13:00 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h (PATCHLEVEL): 12
-
- * Init.scm: loads JCAL if scm is invoked with name JCAL, JACAL,
- jcal or jacal.
-
- * Init.scm (ABS): set to MAGNITUDE if FLOATS are supported.
-
- * gc_mark gc: no longer assume sizeof(short) == 2.
-
- * config.h (CELL_UP CELL_DN): no longer assume sizeof(CELL) == 8.
-
- From: Brian Hanson, Control Data Corporation. brh@ahse.cdc.com
- * scl.c config.h repl.c: partial port to Control Data NOS/VE.
-
- From: fred@sce.carleton.ca (Fred J Kaudel)
- * repl.c Init.scm makefile.ast: Port to Atari-ST
-
- * sys.c scm.h eval.c (throw): renamed to lthrow to avoid conflict
- with Gnu CC.
-
-Mon Feb 10 14:31:24 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c (delete-file rename-file): added.
-
- * sys.c (chdir): now returns #f instead of error.
-
- * Init.scm: Calls to PROVIDED? inlined so no longer dependent on
- SLIB being loaded. (set! ABS MAGNITUDE) if inexacts supported.
- Support for slib1b3 added.
-
- * sys.c (alloc_some_heap): fixed bugs. One fix from
- bowles@is.s.u-tokyo.ac.jp.
-
- * eval.c (ceval): fixed bug with internal (define foo bar) where
- bar is a global. Put badfun2: back in for better error reporting.
-
- * patchlvl.h (PATCHLEVEL): 11
-
-Mon Jan 20 16:19:04 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * config.c (INITS): comments added.
-
- From: T. Kurt Bond, tkb@mtnet2.wvnet.edu
- * VMSGCC.COM VMSMAKE.COM: now take arguments.
-
- From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de>
- * makefile.aztec repl.c: Aztec C (makefile) port.
-
-Fri Jan 17 16:36:07 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c (gc init_storage stack_size): stack_size now of type
- sizet. init_storage no longer uses it. gc() now uses it instead
- of pointer to local. This fixes bug with gcc -O.
-
- * sys.c (cons cons2 cons2r): &w;&x;&y; removed because of above
- fix.
-
-Thu Jan 16 22:33:00 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * scl.c (real-part): added.
-
-Wed Jan 15 13:06:39 1992 Aubrey Jaffer (jaffer at Ivan)
-
- From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de>
- * scl.c repl.c scm.c config.c: Port for AMIGA
-
- * scm.h (REALP): fixed for SINGLES not defined.
-
-Sat Jan 11 20:20:40 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h (PATCHLEVEL): 8 released.
-
- * README: added hints for EDITING SCHEME CODE.
-
- * repl.c (SIGRETTYPE): now int for __TURBOC__.
-
- * makefile.tur makefile.djg: created.
-
- * config.h: DJGPP (__GO32__) support added.
-
- * scm.h (memv): definition added.
-
-Sun Jan 5 00:33:44 1992 Aubrey Jaffer (jaffer at Ivan)
-
- * repl.c makefile.* (main): INITS added.
-
- * scl.c: fixed ASSERT statements with mismatched ARGn and
- arguments.
-
-Thu Dec 19 19:16:50 1991 Aubrey Jaffer (jaffer at train)
-
- * sys.c (cons cons2 cons2r): added fix for gcc -O bug.
-
- * repl.c (LACK_FTIME LACK_TIMES): more messing with these.
-
- * sys.c config.o (HAVE_PIPE): created.
-
- * config.h (FLT_RADIX): now #ifdef FLT_RADIX rather than __STDC__.
- Needed for DJGCC.
-
- * sys.c (DBLMANT_DIG DBL_FLOAT_DIG): now tested for directly
- rather than STDC_INCLUDES.
-
- * makefile.unix (subr.o): explicit compilation line added.
-
- * scl.c (truncate -> ltrunc): Name conflict with DJGCC libraries.
-
-Sun Dec 8 23:31:04 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * eval.c (apply): added check for number of args to closures.
-
-Sat Dec 7 01:30:46 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h (PATCHLEVEL): 7
-
- * sys.c (chdir): THINK_C doesn't support;
-
- * repl.c: SVR2 needs <time.h> instead of <sys/time.h>
-
- * repl.c: SVR2 needs LACK_FTIME
-
- * repl.c: #include <sys/timeb.h> now automatic ifndef LACK_FTIME.
-
-Mon Dec 2 15:42:11 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h (PATCHLEVEL): 5
-
- * sys.c (intern sysintern): made strings and hash unsigned. Fixed
- bug with characters > 128 in symbols.
-
- * scl.c (eqv? memv assv): created if FLOATS is #defined. From
- boopsy!mike@maccs.dcss.mcmaster.ca (Michael A. Borza).
-
-Mon Dec 2 11:37:11 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h (PATCHLEVEL): 4
-
- * sys.c (gc_sweep): usaage of pclose() now conditional on unix.
-
- * MANUAL (chdir): documented.
-
- from T. Kurt Bond, Adminisoft, Inc. <tkb@MTNET2.WVNET.EDU>:
-
- * repl.c sys.c (errno): VMS GNU C uses a special hack in <errno.h>
- to get the link-time attributes for the errno variable to match
- those the VMS C run-time library expects (it makes errno a
- preprocessor define so that the variable that the compiler sees
- has a special form that the assember then interprets), so if it is
- VMS and __GNUC__ is defined <errno.h> needs included.
-
- * setjump.h (SETJUMP LONGJUMP): SETJUMP and LONGJUMP changed to
- setjump and longjump. The VMS linker is case-indifferent. VMS GNU
- C mangles variable names that have upper case letters in them to
- preserve their uniqueness.
-
- * sys.c (iprint iprin1): Now inline putc loops instead of calls to
- fwrite for VMS. The VMS `fwrite' has been enhanced to work with
- VMS's Record Management Sevice, RMS. Part of this enhancement is
- to treat each call to `fwrite' as producing a separate record.
- This works fine if you are writing to a stream_LF file or an
- actual terminal screen, but if you are writing to a file that has
- implied carriage control (such as a batch log file, or a mailbox
- used for subprocess communication), which is a more common file
- organization for RMS, each call to `fwrite' has a newline appended
- to it. This causes much of the output to be incorrectly split
- across lines.
-
- * vmsgcc.com: created.
-
-Sun Dec 1 00:33:42 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h (PATCHLEVEL): 3 released.
-
- * Init.scm (rev2-procedures): all now supported.
-
- * Init.scm sys.c MANUAL (flush): flush changed to force-output to
- be compatible with Common Lisp.
-
- * sys.c (chdir): added.
-
-Wed Nov 27 09:37:20 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h (PATCHLEVEL): 2
-
- * repl.c (set-errno! perror): added.
-
- * sys.c (gc): FLUSH_REGISTER_WINDOWS call added.
-
- * sys.c (open-input-pipe open-output-pipe close-pipe): added.
-
-Mon Nov 25 13:02:13 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h (PATCHLEVEL): 1
-
- * sys.c (flush): added.
-
- * repl.c (mytime): macro was missing (). CLKTCK now defaults to 60.
-
- * README Init.scm subr.c scm.c repl.c scl.c: From Yasuaki Honda,
- honda@csl.SONY.co.jp, support for Macintosh running Think C.
-
-Sun Nov 24 15:30:51 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scl.c (str2flo): fixed parsing of -1-i.
-
- * repl.c (repl_driver): from jjc@jclark.com, now checks that
- s_response is non-NULL before INTERNing.
-
- * subr.c (equal): Now correct for inexacts. Need to do eqv.
-
- * scm.h (REALPART): fixed pixel C compiler bug with doubles inside
- `?' conditionals.
-
- * scl.c (zerop): now checks imaginary half of complex number.
-
-Tue Nov 19 00:10:59 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * version scm3c0
-
- * documentation: changed revised^3.99 to revised^4.
-
- * example.scm: created from Scheme^4 spec.
-
- * makefile.msc: -Ox changed to -Oxp to fix over-enthusiastic float
- optimizations.
-
- * Init.scm (ed): defined.
-
- * repl.c (def_err_response): UNDEFINED objects don't print out.
-
-Sun Nov 17 23:11:03 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scl.c (vms-debug): now returns UNSPECIFIED.
-
- * repl.c MANUAL (restart_repl): RESTART-REPL changed to ABORT.
-
- * repl.c (err_ctrl_c):now clears sig_pending.
-
-Wed Nov 13 23:51:36 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * config.h: removed #ifdef sparc #define STDC_HEADERS
-
- * makefile.bor: added extra '\' to filepath.
-
- * repl.c (everr): fixed bug with ARGx.
-
- * repl.c (errmsgs def_err_response): cleaned up error messages.
-
-Sun Nov 10 23:10:24 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * released scm3b7
-
-Mon Nov 4 18:36:49 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h (PATCHLEVEL): 6
-
- * sys.c (idbl2str): tests for Not-a-Number and Infinity added.
-
- * repl.c scm.h: response system rewritten and integrated with
- error system.
-
- * scl.c (/): now returns inexacts if integer arguments do not
- divide evenly.
-
-Mon Oct 28 23:44:16 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * makefile.unix: can now make float (scm) and integer-only (escm)
- versions in same directory.
-
- * repl.c (*sigint-response* *arithmetic-response* restart-repl):
- responses for signals added.
-
- * scl.c (lmin lmax sum difference product divide expt exp log):
- now take mixed types. expt available in non-FLOATS compilation.
-
- * repl.c (get-decoded-time): added. Includes and time functions
- reorganized.
-
- * sys.c (object-hash object-unhash): added.
-
-Tue Oct 15 00:45:35 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * repl.c Init.scm (*features*): moved constant features into
- Init.scm. Moved tests for numeric features to slib/require.scm.
-
- * release scm3b1.
-
- * config.h (ANSI_INCLUDES): redid include files.
-
- * subr.c scl.c: moved all FLOAT conditionals from subr.c to scl.c.
-
-Wed Oct 9 00:28:54 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * release scm3a13.
-
- * patchlvl.h (PATCHLEVEL): 13
-
- * Init.scm: "vicinity.scm" changed to "require.scm"
-
-Mon Oct 7 00:34:07 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * test.scm: test of redefining built-in symbol and extra ')'
- removed.
-
- * scm.doc makefile.unix: scm.doc created from scm.1 in
- makefile.unix.
-
- * VMSBUILD.COM setjump.asm setjump.h (setjmp longjmp jmp_buf): put
- in from comp.sources.reviewed in order to let VMS have full
- continuations. VMSBUILD.COM is a compile script.
-
-Fri Oct 4 00:05:54 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scl.c(sleep): removed; not supported by MSC (although could be
- written).
-
- * scm.h config.h (size_t): moved to config.h.
-
- * sys.c (f_getc): -> lgetc for vax, getc otherwise.
-
- * patchlvl.h (PATCHLEVEL): 12
-
-Mon Sep 30 01:14:48 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scl.c(sleep): created.
-
- * repl.c(internal-time-units-per-second get=internal-run-time):
- created
-
- * repl.c: created from scm.c (shuffled around lots of functions).
-
-Sat Sep 28 00:22:30 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scm.c config.h (char-code-limit most-positive-fixnum
- most-negative-fixnum): created.
-
-Tue Sep 24 01:21:43 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scm.c (software-type); created.
-
- * scm.c config.h (terms, list-file, library-vicinity,
- program-vicinity, user-vicinity, make-vicinity, sub-vicinity):
- moved to Init.scm and library.
-
- * scm.c config.h Makefile (PROGPATH): changed to IMPLPATH.
-
- * Init.scm: created
-
-Fri Sep 20 13:22:08 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * patchlvl.h (PATCHLEVEL): 5
-
- * all: changed declarations to size_t where appropriate. scm.h
- test preprocessor flag _SIZE_T to determine if already declared.
- size_t should greatly enhance portability to Macintosh and other
- machines.
-
-Tue Sep 17 01:15:31 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scm.c (tmpnam): support for mktemp added.
-
-Mon Sep 16 14:06:26 1991 Aubrey Jaffer (jaffer at train)
-
- * scm.c (implementation-vicinity): added. (program-vicinity) now
- returns undefined if called not within a load.
-
- * sys.c (call-with-io-file): removed.
-
- * scm.c (tmpnam): added.
-
- * scm.c config.h (tmporary-vicinity): removed.
-
-Sun Sep 15 22:21:30 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * subr.c scm.h (remainder): renamed to lremainder to avoid
- conflict with math.h on SunOS4.1 (from bevan@cs.man.ac.uk).
-
-Sat Sep 7 22:27:49 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scm.c (program-arguments load): program-arguments created.
-
- * scm.c (getenv): added getenv and used for program-vicinity and
- library-vicinity.
-
- * scm.c (program-vicinity): fixed if load_name is NULL.
-
- * scl.c config.h (substring-move-left! substring-move-right!):
- added under STR_EXTENSIONS flag.
-
-Wed Aug 28 22:59:20 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * Sending scm3a to comp.sources.reviewed
-
- * scm.c (main): prints out feature list at startup.
-
- * subr.c (eqp lessp greaterp lesseqp greatereqp): now work for
- floats.
-
- * scl.c (sum difference divide product): moved to scl.c and
- now work for floats.
-
- * all: all masks with low bits explicity cast to (int).
-
-Sat Aug 17 00:39:06 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c subr.c scl.c (iint2str istr2int istring2number istr2flo
- iflo2str idbl2str): number I/O and conversion to strings rewritten.
-
- * sys.c (gc_mark): continuations now marked SHORT_ALIGNed. (from
- Craig Lawson).
-
- * added QuickC support from Craig Lawson.
-
-Tue Jul 30 01:08:52 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * config.h: #ifdef pyr added.
-
- * scm.c MANUAL: vicinity functions added.
-
-Tue Jul 16 00:51:23 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scl.c sys.c: float functions added.
-
- * Documentation reorganized according to comp.sources.reviewed
- guidelines.
-
- * sys.c config.h (open_input_file open_output_file open_rw_file):
- file mode string moved to defines in config.h
-
-Thu Jul 11 23:30:03 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c config.h (EBCDIC ASCII) moved to config.h
-
- * subr.c config.h (BADIVSGNS) moved to config.h
-
- * scm.h config.h (SRS) moved to config.h
-
-Sun Jul 7 23:49:26 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * all: started adding comp.sources.reviewed corrections and
- suggestions.
-
- * scm.c patchlvl.h (main): PATCHLEVEL now printed in banner.
-
- * subr.c sys.c: read_integer removed. istring2number created.
- lread and string2number now both use istring2number.
-
-Fri Jun 7 13:43:40 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * VERSION scm2e sent to comp.sources.reviewed
-
- * public.lic: renamed COPYING.
-
- * scm.c (gc_status): gc_status renamed prolixity. Now returns old
- value of verbose. Can take 0 arguments.
-
- * sys.c (lreadr): added #| common lisp style |# balanced comments.
-
- * scm.h scm.c sys.c (I/O functions): combined **PORTP and OPENP to
- become OP**PORTP.
-
- * scm.h sys.c (gc_sweep): moved OPENP to bit in upper half word of
- port cells.
-
-Sat May 25 00:04:45 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scm.c (stack_start_ptr, repl_driver, main, err functions):
- exits removed from all err functions. all escapes through
- repl_driver.
-
- * scm.c README (verbose): Now has graded verbosity.
-
- * scm.c README (quit): Now takes optional argument which is return
- value.
-
-Wed May 22 01:40:17 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * code.doc scm.h eval.c (ceval): Rearanged immediate type codes to
- create IXSYMs (immediate extension syms) to allow more than 15
- special forms. ILOCs now work with up to 32767 in one environment
- frame. Dispatch is slightly faster for ILOCs in function position.
- ICHRs can be up to 24 bits.
-
-Fri May 10 00:16:32 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scm.h sys.c (gc_mark, gc_sweep): GCMARK moved to bit 8 of CAR
- for some datatypes.
-
-Wed May 1 14:11:05 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * patch1 MESSAGE SENT.
-
- * sys.c (lreadr) from jclark@bugs.specialix.co.uk.jjc: removed
- order evaluation bug when growing tok_buf.
-
-Fri Apr 26 10:39:41 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scm2d RELEASED
-
- * sys.c (closure) no longer calls ilength (ECONS problem). Added
- ASSERT before call to closure in eval.
-
-Thu Apr 25 09:53:40 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * scm.c (error): created.
-
-Wed Apr 24 16:58:06 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * utils.scm: created.
-
- * makefile (name8s): code from dmason works in makefile.
-
- * eval.c (evalcar): fixed errobj on (else 3 4) error.
- Inlined function application in (cond ((foo => fun))).
-
- * sys.c (lprin1): change looped putcs to fwrite.
-
-Wed Apr 24 01:54:09 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c (lreadr): fixed assert for "eof in string".
-
- * subr.c (lgcd): changed to work with borland C.
-
- * eval.c (eval): added checks to LAMBDA and LET.
-
- * eval.c (apply): now checks for null arg1 in lsubr.
-
-Fri Apr 12 00:09:03 1991 Aubrey Jaffer (jaffer at kleph)
-
- * config.h scm.h (SCMPTR): created to correct address arithmetic
- on stack bounds under Borland C++. Borland C++ now runs scm2c.
-
-Wed Apr 10 21:38:09 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c (open_io_file, cw_io_file, file_position, file_set_pos,
- read_to_str) created (IO_EXTENSIONS)
-
- * config.h (IO_EXTENSIONS): defined
-
- * sys.c scm.c: lprin1f changed to iprin1
-
-Wed Apr 10 12:58:59 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * sys.c (intern): line 850: for(i = alen;0 <= --i;)changed to
- for(i = alen;0 < --i;).
- This fixed b_pos and v_pos mapping to the same symbol.
-
-Wed Apr 4 00:00:00 1991 Aubrey Jaffer (jaffer at kleph.ai.mit.edu)
-
- * released scm2b
-
-Wed Apr 3 22:51:39 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * all files: eliminated types tc7_subr_2n and tc7_subr_2xn.
- Replaced with tc7_subr_2o and tc7_subr_1o so that all subr calls
- can be checked for number of arguments.
-
-Tue Apr 2 23:11:15 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * code.doc: cleaned up.
-
-Mon Apr 1 14:27:22 1991 Aubrey Jaffer (jaffer at Ivan)
-
- * eval.c (ceval): fixed nasty tail recursion bug at carloop:.
-
- * scm.c (everr): still fixing error reporting.
-
- * eval.c subr.c: added flag PURE_FUNCTIONAL which removes side
- effect special forms and functions.
-
- * subr.c (substring): now allows first index to be equal to length
- of string
-
- * sys.c (lprin1f): dispatches on TYP16 of smobs.
-
- * scm.h: fixed typo in unused function defs.
-
-Mon Mar 28 00:00:00 1991 Aubrey Jaffer (jaffer at zohar.ai.mit.edu)
-
- * scm2a released: too many changes to record. See code.doc.
-
-Mon Feb 18 21:48:24 1991 Aubrey Jaffer (jaffer at foxkid)
-
- * scm.h: types reformatted (TYP6 -> TYP7).
-
- * eval.c (ceval): Now dispatch directly on ISYMs in ceval.
-
-Fri Feb 15 23:39:48 1991 Aubrey Jaffer (jaffer at foxkid)
-
- * sys.c: #include <malloc.h> not done for VMS
-
-Wed Feb 13 17:49:33 1991 Aubrey Jaffer (jaffer at foxkid)
-
- * scm.c scl.c: added unsigned declarations to some char *
- definitions in order to fix characters having negative codes.
-
- * scm.h (MAKISYM, MAKFLAG, ICHR, MAKICHR, MAKINUM): Now cast to
- long so that their calls don't have to. Changing MAKICHR fixed
- problem in scl.c (string2list) on IBMPC.
-
- * subr.c (quotient): support for `/' reintroduced; required by
- r3.99rs but not IEEE.
-
- * subr.c (char functions): added isascii tests for
- char-alphabetic, char-numeric?, char-whitespace?,
- char-upper-case?, and char-lower-case?. Added test against
- char_code_limit to int2char.
-
- * subr.c (s_char_alphap): is subr_1 not lsubr.
-
- * test.scm: added tests for char-alphabetic, char-numeric?,
- char-whitespace?, char-upper-case?, and char-lower-case?.
-
- * sys.c: most `return;'s eliminated to reduce warning messages.
- Substituted breaks and reordered switch and if clauses.
-
-Sun Feb 3 23:12:34 1991 Aubrey Jaffer (jaffer at foxkid)
-
- * scm1-2: released.
-
- * sys.c (read-char peek-char) added code for EOF.
-
- * test.scm (leaf-eq?) added and file "cont.scm" removed. I/O
- tests added.
-
- * sys.c (I/O functions) now check for input and output ports
- rather than just ports.
-
- * sys.c (lprin1f): occurences of stdout changed to f. Newlines
- after printing port removed.
-
-Thu Jan 31 22:52:39 1991 Aubrey Jaffer (jaffer at foxkid)
-
- * subr.c (quotient): support for `/' removed; not required.
-
- * scm.c (wta): message for OUTOFRANGE fixed.
-
-Mon Jan 28 12:45:55 1991 Aubrey Jaffer (jaffer at foxkid)
-
- * eval.c (apply): added checks for number of arguments.
-
- * scm.h (CHECK_SIGINT): checks for blocked SIGINT.
-
- * sys.c (lprin1): added blocking and testing for SIGINT so that
- output won't hang on VMS.
-
- * scm.c (repl): added fflush call.
-
- * scm.c (err_head, wta): added fflush calls to error routines so
- that error message come out in proper order.
-
diff --git a/libguile/DYNAMIC-LINKING b/libguile/DYNAMIC-LINKING
deleted file mode 100644
index cb7134318..000000000
--- a/libguile/DYNAMIC-LINKING
+++ /dev/null
@@ -1,95 +0,0 @@
-Random notes about dynamic linking for Guile. I will update this file
-as I go along. Comments are very welcome. I can be reached at
-mvo@zagadka.ping.de (Marius Vollmer).
-
-The dynamic linking support is mostly untested. I can't test it
-because I don't have all the different platforms, of course. Please
-try it out.
-
-To enable support for dynamic linking in libguile, give the
-
- --enable-dynamic-linking
-
-option to configure. It is disabled by default because it will
-probably cause lots of problems in its present state. Currently there
-is support for -ldld, -ldl, HP-UX (and VMS, but not really).
-
-Files affected:
-
- dynl* new
- configure.in add --enable-dynamic-linking option and checking for
- system dependencies
- Makefile.am include dynl* in build and dist.
- init.c initialize dynamic linking support
-
-Here is my plan with indications of progress.
-
-- port "dynl.c" and maybe some parts of "Link.scm" from SCM to
- Guile. This should not be difficult, maybe I can even squeeze the
- VMS code into the "dynl:link", "dyn:call" interface.
-
-* Mostly done, except VMS, and almost completely untested. The -dl
- support should work, but the rest has not even been compiled.
-
- The code is in the "dynl*" files. "dynl.c" is the system independent
- portion and includes the appropriate system dependent file, either
- "dynl-dld.c", "dynl-dl.c" or "dynl-shl.c".
-
- I have renamed the SCM names of the functions, because they didnn't
- fit very well into Guile, the semantics are the same:
-
- SCM name Guile name
-
- dynl:link dynamic-link
- dynl:call dynamic-call
- dynl:main-call dynamic-args-call
- dynl:unlink dynamic-unlink
-
- I plan to generalise dynamic-call and dynamic-args-call to work with
- arbitrary arguments, so these names are likely to change.
-
- PROBLEMS:
-
- When including dynlink support in libguile you need to link your
- applications with additional libraries (-ldl or -ldld). How do you
- communicate this to "guile" and "gh_test" for example? Some PLUGIN
- magic?
-
- You may need to link your application in a special way to make
- dynamic linking work. For example, on Linux and a statically linked
- libguile.a, you need -rdynamic to make the libguile symbols
- available for dynamic linking. The solution is probably to build
- libguile as a shared library on the systems that support it. Does
- libtool help here? Where can I find it?
-
-
-- see how to couple dynamic linking with the module system. Dynamic
- objects should have a way to specify the module they want to add
- their bindings to. Extend this to statically linked parts of
- guile. (i.e. posix could be put into a module and initialized on
- demand)
-
-* Maybe it will suffice to have scm_make_gsubr, etc to honor the
- current scm_top_level_lookup_closure and do all the module switching
- from Scheme.
-
-
-- use gtcltk as a test case for the above, so that TCL/Tk capabilities
- can be added to guile at runtime.
-
-- see how G-Wrap and libffi can work together and extend dyn:call to
- functions taking arbitrary arguments. Something along the lines
-
- (define XOpenDisplay (make-foreign-function X11-lib 'XOpenDisplay
- .. whatever args ..))
-
-
-I have no ideas how to support the development of packages for Guile
-that can be dynamically linked into a running application. Maybe
-automake can be used to automate most of the issues.
-
-One nice thing is, however, that developers and users of Guile
-packages have already installed Guile. So we might able to use Scheme
-to describe and handle the build process. I would like that much more
-than the arcane shell based implementations of autoconf, automake,
-etc.
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
deleted file mode 100644
index b944b49be..000000000
--- a/libguile/Makefile.am
+++ /dev/null
@@ -1,60 +0,0 @@
-## Process this file with Automake to create Makefile.in
-
-AUTOMAKE_OPTIONS = foreign
-
-## Check for headers in $(srcdir)/.., so that #include
-## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
-## building.
-INCLUDES = -I.. -I$(srcdir)/..
-
-lib_LIBRARIES = libguile.a
-libguile_a_SOURCES = alist.c append.c appinit.c arbiters.c async.c \
-backtrace.c boolean.c chars.c continuations.c debug.c dynl.c dynwind.c eq.c \
-error.c eval.c extchrs.c fdsocket.c feature.c filesys.c fports.c gc.c \
-gdbint.c genio.c gsubr.c hash.c hashtab.c inet_aton.c init.c ioext.c \
-kw.c list.c load.c mallocs.c markers.c mbstrings.c numbers.c objprop.c \
-options.c pairs.c ports.c posix.c print.c procprop.c procs.c ramap.c \
-read.c root.c scmsigs.c sequences.c simpos.c smob.c socket.c srcprop.c \
-stackchk.c stacks.c stime.c strerror.c strings.c strop.c strorder.c \
-strports.c struct.c symbols.c tag.c throw.c unif.c variable.c \
-vectors.c version.c vports.c weaks.c _scm.h
-
-include_HEADERS = libguile.h
-
-# These are headers visible as <libguile/mumble.h>.
-modincludedir = $(includedir)/@module@
-modinclude_HEADERS = __scm.h alist.h append.h arbiters.h async.h \
-backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h eq.h \
-error.h eval.h extchrs.h fdsocket.h feature.h filesys.h fports.h gc.h \
-gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h ioext.h \
-kw.h list.h load.h mallocs.h markers.h mbstrings.h numbers.h objprop.h \
-options.h pairs.h ports.h posix.h print.h procprop.h procs.h ramap.h read.h \
-root.h scmhob.h scmsigs.h sequences.h simpos.h smob.h socket.h srcprop.h \
-stackchk.h stacks.h stime.h strings.h strop.h strorder.h strports.h struct.h \
-symbols.h tag.h tags.h throw.h unif.h variable.h vectors.h version.h \
-vports.h weaks.h snarf.h
-
-## This file is generated at configure time. That is why it is DATA
-## and not a header -- headers are included in the distribution.
-modinclude_DATA = scmconfig.h
-
-bin_SCRIPTS = guile-snarf
-
-EXTRA_DIST = gscm.c gscm.h ChangeLog-scm dynl-dl.c dynl-dld.c dynl-shl.c \
-dynl-vms.c PLUGIN/REQ PLUGIN/guile.config PLUGIN/guile.libs
-
-## FIXME: shouldn't directly generate file; instead generate temp file
-## and "mv". Consider using timestamp file as well, to avoid
-## unnecessary rebuilds.
-libpath.h: Makefile
- echo '/* generated by Makefile */' > libpath.h
- echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.h
- echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(VERSION)"' >> libpath.h
- echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.h
-
-SUFFIXES = .x
-.c.x:
- ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@
-
-## Add -MG to make the .x magic work with auto-dep code.
-MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
diff --git a/libguile/Makefile.in b/libguile/Makefile.in
deleted file mode 100644
index 6c779f9e3..000000000
--- a/libguile/Makefile.in
+++ /dev/null
@@ -1,478 +0,0 @@
-# Makefile.in generated automatically by automake 1.1l from Makefile.am
-
-# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
-# This Makefile.in is free software; the Free Software Foundation
-# gives unlimited permission to copy, distribute and modify it.
-
-
-SHELL = /bin/sh
-
-srcdir = @srcdir@
-top_srcdir = @top_srcdir@
-VPATH = @srcdir@
-prefix = @prefix@
-exec_prefix = @exec_prefix@
-
-bindir = @bindir@
-sbindir = @sbindir@
-libexecdir = @libexecdir@
-datadir = @datadir@
-sysconfdir = @sysconfdir@
-sharedstatedir = @sharedstatedir@
-localstatedir = @localstatedir@
-libdir = @libdir@
-infodir = @infodir@
-mandir = @mandir@
-includedir = @includedir@
-oldincludedir = /usr/include
-
-pkgdatadir = $(datadir)/@PACKAGE@
-pkglibdir = $(libdir)/@PACKAGE@
-pkgincludedir = $(includedir)/@PACKAGE@
-
-top_builddir = .
-
-INSTALL = @INSTALL@
-INSTALL_PROGRAM = @INSTALL_PROGRAM@
-INSTALL_DATA = @INSTALL_DATA@
-INSTALL_SCRIPT = @INSTALL_SCRIPT@
-transform = @program_transform_name@
-VERSION = @VERSION@
-RANLIB = @RANLIB@
-INSTALL_SCRIPT = @INSTALL_SCRIPT@
-module = @module@
-CC = @CC@
-PACKAGE = @PACKAGE@
-FD_SETTER = @FD_SETTER@
-
-AUTOMAKE_OPTIONS = foreign
-
-INCLUDES = -I.. -I$(srcdir)/..
-
-lib_LIBRARIES = libguile.a
-libguile_a_SOURCES = alist.c append.c appinit.c arbiters.c async.c \
-backtrace.c boolean.c chars.c continuations.c debug.c dynl.c dynwind.c eq.c \
-error.c eval.c extchrs.c fdsocket.c feature.c filesys.c fports.c gc.c \
-gdbint.c genio.c gsubr.c hash.c hashtab.c inet_aton.c init.c ioext.c \
-kw.c list.c load.c mallocs.c markers.c mbstrings.c numbers.c objprop.c \
-options.c pairs.c ports.c posix.c print.c procprop.c procs.c ramap.c \
-read.c root.c scmsigs.c sequences.c simpos.c smob.c socket.c srcprop.c \
-stackchk.c stacks.c stime.c strerror.c strings.c strop.c strorder.c \
-strports.c struct.c symbols.c tag.c throw.c unif.c variable.c \
-vectors.c version.c vports.c weaks.c _scm.h
-
-include_HEADERS = libguile.h
-
-# These are headers visible as <libguile/mumble.h>.
-modincludedir = $(includedir)/@module@
-modinclude_HEADERS = __scm.h alist.h append.h arbiters.h async.h \
-backtrace.h boolean.h chars.h continuations.h debug.h dynl.h dynwind.h eq.h \
-error.h eval.h extchrs.h fdsocket.h feature.h filesys.h fports.h gc.h \
-gdb_interface.h gdbint.h genio.h gsubr.h hash.h hashtab.h init.h ioext.h \
-kw.h list.h load.h mallocs.h markers.h mbstrings.h numbers.h objprop.h \
-options.h pairs.h ports.h posix.h print.h procprop.h procs.h ramap.h read.h \
-root.h scmhob.h scmsigs.h sequences.h simpos.h smob.h socket.h srcprop.h \
-stackchk.h stacks.h stime.h strings.h strop.h strorder.h strports.h struct.h \
-symbols.h tag.h tags.h throw.h unif.h variable.h vectors.h version.h \
-vports.h weaks.h snarf.h
-
-modinclude_DATA = scmconfig.h
-
-bin_SCRIPTS = guile-snarf
-
-EXTRA_DIST = gscm.c gscm.h ChangeLog-scm dynl-dl.c dynl-dld.c dynl-shl.c \
-dynl-vms.c PLUGIN/REQ PLUGIN/guile.config PLUGIN/guile.libs
-
-SUFFIXES = .x
-
-MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
-ACLOCAL = $(top_srcdir)/aclocal.m4
-CONFIG_HEADER_IN = scmconfig.h.in
-mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
-CONFIG_HEADER = scmconfig.h
-CONFIG_CLEAN_FILES = fd.h guile-snarf
-LIBRARIES = $(lib_LIBRARIES)
-
-
-DEFS = @DEFS@ -I. -I$(srcdir) -I.
-CPPFLAGS = @CPPFLAGS@
-LDFLAGS = @LDFLAGS@
-LIBS = @LIBS@
-libguile_a_LIBADD =
-libguile_a_OBJECTS = alist.o append.o appinit.o arbiters.o async.o \
-backtrace.o boolean.o chars.o continuations.o debug.o dynl.o dynwind.o \
-eq.o error.o eval.o extchrs.o fdsocket.o feature.o filesys.o fports.o \
-gc.o gdbint.o genio.o gsubr.o hash.o hashtab.o inet_aton.o init.o \
-ioext.o kw.o list.o load.o mallocs.o markers.o mbstrings.o numbers.o \
-objprop.o options.o pairs.o ports.o posix.o print.o procprop.o procs.o \
-ramap.o read.o root.o scmsigs.o sequences.o simpos.o smob.o socket.o \
-srcprop.o stackchk.o stacks.o stime.o strerror.o strings.o strop.o \
-strorder.o strports.o struct.o symbols.o tag.o throw.o unif.o \
-variable.o vectors.o version.o vports.o weaks.o
-AR = ar
-SCRIPTS = $(bin_SCRIPTS)
-
-CFLAGS = @CFLAGS@
-COMPILE = $(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
-LINK = $(CC) $(LDFLAGS) -o $@
-DATA = $(modinclude_DATA)
-
-HEADERS = $(modinclude_HEADERS) $(include_HEADERS)
-
-DIST_COMMON = COPYING ChangeLog Makefile.am Makefile.in acconfig.h \
-acinclude.m4 aclocal.m4 configure configure.in fd.h.in guile-snarf.in \
-scmconfig.h.in stamp-h.in
-
-
-DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \
- $(TEXINFOS) $(MANS) $(EXTRA_DIST)
-
-TAR = tar
-DEP_FILES = .deps/alist.P .deps/append.P .deps/appinit.P \
-.deps/arbiters.P .deps/async.P .deps/backtrace.P .deps/boolean.P \
-.deps/chars.P .deps/continuations.P .deps/debug.P .deps/dynl.P \
-.deps/dynwind.P .deps/eq.P .deps/error.P .deps/eval.P .deps/extchrs.P \
-.deps/fdsocket.P .deps/feature.P .deps/filesys.P .deps/fports.P \
-.deps/gc.P .deps/gdbint.P .deps/genio.P .deps/gsubr.P .deps/hash.P \
-.deps/hashtab.P .deps/inet_aton.P .deps/init.P .deps/ioext.P .deps/kw.P \
-.deps/list.P .deps/load.P .deps/mallocs.P .deps/markers.P \
-.deps/mbstrings.P .deps/numbers.P .deps/objprop.P .deps/options.P \
-.deps/pairs.P .deps/ports.P .deps/posix.P .deps/print.P \
-.deps/procprop.P .deps/procs.P .deps/ramap.P .deps/read.P .deps/root.P \
-.deps/scmsigs.P .deps/sequences.P .deps/simpos.P .deps/smob.P \
-.deps/socket.P .deps/srcprop.P .deps/stackchk.P .deps/stacks.P \
-.deps/stime.P .deps/strerror.P .deps/strings.P .deps/strop.P \
-.deps/strorder.P .deps/strports.P .deps/struct.P .deps/symbols.P \
-.deps/tag.P .deps/throw.P .deps/unif.P .deps/variable.P .deps/vectors.P \
-.deps/version.P .deps/vports.P .deps/weaks.P
-SOURCES = $(libguile_a_SOURCES)
-OBJECTS = $(libguile_a_OBJECTS)
-
-default: all
-
-.SUFFIXES:
-.SUFFIXES: .c .o .x
-$(srcdir)/Makefile.in: Makefile.am $(top_srcdir)/configure.in $(ACLOCAL)
- cd $(top_srcdir) && automake --foreign Makefile
-
-Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES)
- cd $(top_builddir) \
- && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
-
-$(srcdir)/aclocal.m4: configure.in acinclude.m4
- cd $(srcdir) && aclocal
-
-config.status: configure
- $(SHELL) ./config.status --recheck
-$(srcdir)/configure: configure.in $(ACLOCAL) $(CONFIGURE_DEPENDENCIES)
- cd $(srcdir) && autoconf
-
-$(CONFIG_HEADER): stamp-h
-stamp-h: $(CONFIG_HEADER_IN) $(top_builddir)/config.status
- cd $(top_builddir) \
- && CONFIG_FILES= CONFIG_HEADERS=$(CONFIG_HEADER) \
- $(SHELL) ./config.status
- @echo timestamp > stamp-h
-$(srcdir)/$(CONFIG_HEADER_IN): stamp-h.in
-$(srcdir)/stamp-h.in: $(top_srcdir)/configure.in $(ACLOCAL) acconfig.h
- cd $(top_srcdir) && autoheader
- echo timestamp > $(srcdir)/stamp-h.in
-
-mostlyclean-hdr:
-
-clean-hdr:
-
-distclean-hdr:
- rm -f $(CONFIG_HEADER)
-
-maintainer-clean-hdr:
-fd.h: $(top_builddir)/config.status fd.h.in
- cd $(top_builddir) && CONFIG_FILES=$@ CONFIG_HEADERS= ./config.status
-guile-snarf: $(top_builddir)/config.status guile-snarf.in
- cd $(top_builddir) && CONFIG_FILES=$@ CONFIG_HEADERS= ./config.status
-
-mostlyclean-libLIBRARIES:
-
-clean-libLIBRARIES:
- test -z "$(lib_LIBRARIES)" || rm -f $(lib_LIBRARIES)
-
-distclean-libLIBRARIES:
-
-maintainer-clean-libLIBRARIES:
-
-install-libLIBRARIES: $(lib_LIBRARIES)
- $(NORMAL_INSTALL)
- $(mkinstalldirs) $(libdir)
- list="$(lib_LIBRARIES)"; for p in $$list; do \
- if test -f $$p; then \
- echo "$(INSTALL_DATA) $$p $(libdir)/$$p"; \
- $(INSTALL_DATA) $$p $(libdir)/$$p; \
- else :; fi; \
- done
- $(POST_INSTALL)
- @list="$(lib_LIBRARIES)"; for p in $$list; do \
- if test -f $$p; then \
- echo "$(RANLIB) $(libdir)/$$p"; \
- $(RANLIB) $(libdir)/$$p; \
- else :; fi; \
- done
-
-uninstall-libLIBRARIES:
- list="$(lib_LIBRARIES)"; for p in $$list; do \
- rm -f $(libdir)/$$p; \
- done
-
-.c.o:
- $(COMPILE) -c $<
-
-mostlyclean-compile:
- rm -f *.o core
-
-clean-compile:
-
-distclean-compile:
- rm -f *.tab.c
-
-maintainer-clean-compile:
-$(libguile_a_OBJECTS): scmconfig.h
-
-libguile.a: $(libguile_a_OBJECTS) $(libguile_a_DEPENDENCIES)
- rm -f libguile.a
- $(AR) cru libguile.a $(libguile_a_OBJECTS) $(libguile_a_LIBADD)
- $(RANLIB) libguile.a
-
-install-binSCRIPTS: $(bin_SCRIPTS)
- $(NORMAL_INSTALL)
- $(mkinstalldirs) $(bindir)
- @list="$(bin_SCRIPTS)"; for p in $$list; do \
- if test -f $$p; then \
- echo "$(INSTALL_SCRIPT) $$p $(bindir)/`echo $$p|sed '$(transform)'`"; \
- $(INSTALL_SCRIPT) $$p $(bindir)/`echo $$p|sed '$(transform)'`; \
- else if test -f $(srcdir)/$$p; then \
- echo "$(INSTALL_SCRIPT) $(srcdir)/$$p $(bindir)/`echo $$p|sed '$(transform)'`"; \
- $(INSTALL_SCRIPT) $(srcdir)/$$p $(bindir)/`echo $$p|sed '$(transform)'`; \
- else :; fi; fi; \
- done
-
-uninstall-binSCRIPTS:
- list="$(bin_SCRIPTS)"; for p in $$list; do \
- rm -f $(bindir)/`echo $$p|sed '$(transform)'`; \
- done
-
-install-modincludeDATA: $(modinclude_DATA)
- $(NORMAL_INSTALL)
- $(mkinstalldirs) $(modincludedir)
- @list="$(modinclude_DATA)"; for p in $$list; do \
- if test -f $(srcdir)/$$p; then \
- echo "$(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p"; \
- $(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p; \
- else if test -f $$p; then \
- echo "$(INSTALL_DATA) $$p $(modincludedir)/$$p"; \
- $(INSTALL_DATA) $$p $(modincludedir)/$$p; \
- fi; fi; \
- done
-
-uninstall-modincludeDATA:
- list="$(modinclude_DATA)"; for p in $$list; do \
- rm -f $(modincludedir)/$$p; \
- done
-
-install-modincludeHEADERS: $(modinclude_HEADERS)
- $(NORMAL_INSTALL)
- $(mkinstalldirs) $(modincludedir)
- @list="$(modinclude_HEADERS)"; for p in $$list; do \
- echo "$(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p"; \
- $(INSTALL_DATA) $(srcdir)/$$p $(modincludedir)/$$p; \
- done
-
-uninstall-modincludeHEADERS:
- list="$(modinclude_HEADERS)"; for p in $$list; do \
- rm -f $(modincludedir)/$$p; \
- done
-
-install-includeHEADERS: $(include_HEADERS)
- $(NORMAL_INSTALL)
- $(mkinstalldirs) $(includedir)
- @list="$(include_HEADERS)"; for p in $$list; do \
- echo "$(INSTALL_DATA) $(srcdir)/$$p $(includedir)/$$p"; \
- $(INSTALL_DATA) $(srcdir)/$$p $(includedir)/$$p; \
- done
-
-uninstall-includeHEADERS:
- list="$(include_HEADERS)"; for p in $$list; do \
- rm -f $(includedir)/$$p; \
- done
-
-tags: TAGS
-
-ID: $(HEADERS) $(SOURCES)
- here=`pwd` && cd $(srcdir) && mkid -f$$here/ID $(SOURCES) $(HEADERS)
-
-TAGS: $(HEADERS) $(SOURCES) scmconfig.h.in $(TAGS_DEPENDENCIES)
- tags=; \
- here=`pwd`; \
- list="$(SUBDIRS)"; for subdir in $$list; do \
- test -f $$subdir/TAGS && tags="$$tags -i $$here/$$subdir/TAGS"; \
- done; \
- test -z "$(ETAGS_ARGS)scmconfig.h.in$(SOURCES)$(HEADERS)$$tags" \
- || cd $(srcdir) && etags $(ETAGS_ARGS) $$tags scmconfig.h.in $(SOURCES) $(HEADERS) -o $$here/TAGS
-
-mostlyclean-tags:
-
-clean-tags:
-
-distclean-tags:
- rm -f TAGS ID
-
-maintainer-clean-tags:
-
-distdir = $(PACKAGE)-$(VERSION)
-# This target untars the dist file and tries a VPATH configuration. Then
-# it guarantees that the distribution is self-contained by making another
-# tarfile.
-distcheck: dist
- rm -rf $(distdir)
- $(TAR) zxf $(distdir).tar.gz
- mkdir $(distdir)/=build
- mkdir $(distdir)/=inst
- dc_install_base=`cd $(distdir)/=inst && pwd`; \
- cd $(distdir)/=build \
- && ../configure --srcdir=.. --prefix=$$dc_install_base \
- && $(MAKE) \
- && $(MAKE) dvi \
- && $(MAKE) check \
- && $(MAKE) install \
- && $(MAKE) installcheck \
- && $(MAKE) dist
- rm -rf $(distdir)
- @echo "========================"; \
- echo "$(distdir).tar.gz is ready for distribution"; \
- echo "========================"
-dist: distdir
- -chmod -R a+r $(distdir)
- $(TAR) chozf $(distdir).tar.gz $(distdir)
- rm -rf $(distdir)
-dist-all: distdir
- -chmod -R a+r $(distdir)
- $(TAR) chozf $(distdir).tar.gz $(distdir)
- rm -rf $(distdir)
-distdir: $(DISTFILES)
- rm -rf $(distdir)
- mkdir $(distdir)
- -chmod 755 $(distdir)
- here=`pwd`; distdir=`cd $(distdir) && pwd` \
- && cd $(srcdir) \
- && automake --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --foreign
- $(mkinstalldirs) $(distdir)/PLUGIN
- @for file in $(DISTFILES); do \
- d=$(srcdir); \
- test -f $(distdir)/$$file \
- || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
- || cp -p $$d/$$file $(distdir)/$$file; \
- done
-.deps/.P:
- test -d .deps || mkdir .deps
- echo > $@
-
--include $(DEP_FILES)
-$(DEP_FILES): .deps/.P
-
-mostlyclean-depend:
-
-clean-depend:
-
-distclean-depend:
-
-maintainer-clean-depend:
- rm -rf .deps
-
-.deps/%.P: $(srcdir)/%.c
- @echo "Computing dependencies for $<..."
- @o='o'; \
- test -n "$o" && o='$$o'; \
- $(MKDEP) $< | sed "s/^\(.*\)\.o:/\1.$$o \1.l$$o:/" > $@
-info:
-dvi:
-check: all
- $(MAKE)
-installcheck:
-install-exec: install-libLIBRARIES install-binSCRIPTS
- $(NORMAL_INSTALL)
-
-install-data: install-modincludeDATA install-modincludeHEADERS install-includeHEADERS
- $(NORMAL_INSTALL)
-
-install: install-exec install-data all
- @:
-
-uninstall: uninstall-libLIBRARIES uninstall-binSCRIPTS uninstall-modincludeDATA uninstall-modincludeHEADERS uninstall-includeHEADERS
-
-all: $(LIBRARIES) $(SCRIPTS) $(DATA) $(HEADERS) Makefile scmconfig.h
-
-install-strip:
- $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
-installdirs:
- $(mkinstalldirs) $(libdir) $(bindir) $(modincludedir) $(modincludedir) \
- $(includedir)
-
-
-mostlyclean-generic:
- test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES)
-
-clean-generic:
- test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
-
-distclean-generic:
- rm -f Makefile $(DISTCLEANFILES)
- rm -f config.cache config.log stamp-h
- test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
-
-maintainer-clean-generic:
- test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
- test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES)
-mostlyclean: mostlyclean-hdr mostlyclean-libLIBRARIES \
- mostlyclean-compile mostlyclean-tags mostlyclean-depend \
- mostlyclean-generic
-
-clean: clean-hdr clean-libLIBRARIES clean-compile clean-tags \
- clean-depend clean-generic mostlyclean
-
-distclean: distclean-hdr distclean-libLIBRARIES distclean-compile \
- distclean-tags distclean-depend distclean-generic clean
- rm -f config.status
-
-maintainer-clean: maintainer-clean-hdr maintainer-clean-libLIBRARIES \
- maintainer-clean-compile maintainer-clean-tags \
- maintainer-clean-depend maintainer-clean-generic \
- distclean
- @echo "This command is intended for maintainers to use;"
- @echo "it deletes files that may require special tools to rebuild."
- rm -f config.status
-
-.PHONY: default mostlyclean-hdr distclean-hdr clean-hdr \
-maintainer-clean-hdr mostlyclean-libLIBRARIES distclean-libLIBRARIES \
-clean-libLIBRARIES maintainer-clean-libLIBRARIES uninstall-libLIBRARIES \
-install-libLIBRARIES mostlyclean-compile distclean-compile \
-clean-compile maintainer-clean-compile uninstall-binSCRIPTS \
-install-binSCRIPTS uninstall-modincludeDATA install-modincludeDATA \
-uninstall-modincludeHEADERS install-modincludeHEADERS \
-uninstall-includeHEADERS install-includeHEADERS tags mostlyclean-tags \
-distclean-tags clean-tags maintainer-clean-tags distdir \
-mostlyclean-depend distclean-depend clean-depend \
-maintainer-clean-depend info dvi installcheck install-exec install-data \
-install uninstall all installdirs mostlyclean-generic distclean-generic \
-clean-generic maintainer-clean-generic clean mostlyclean distclean \
-maintainer-clean
-
-
-libpath.h: Makefile
- echo '/* generated by Makefile */' > libpath.h
- echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.h
- echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(VERSION)"' >> libpath.h
- echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.h
-.c.x:
- ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@
-
-# Tell versions [3.59,3.63) of GNU make to not export all variables.
-# Otherwise a system limit (for SysV at least) may be exceeded.
-.NOEXPORT:
diff --git a/libguile/__scm.h b/libguile/__scm.h
deleted file mode 100644
index 22c2eaa38..000000000
--- a/libguile/__scm.h
+++ /dev/null
@@ -1,432 +0,0 @@
-/* classes: h_files */
-
-#ifndef __SCMH
-#define __SCMH
-/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-/* {Supported Options}
- *
- * These may be defined or undefined.
- */
-
-/* If the compile FLAG `CAUTIOUS' is #defined then the number of
- * arguments is always checked for application of closures. If the
- * compile FLAG `RECKLESS' is #defined then they are not checked.
- * Otherwise, number of argument checks for closures are made only when
- * the function position (whose value is the closure) of a combination is
- * not an ILOC or GLOC. When the function position of a combination is a
- * symbol it will be checked only the first time it is evaluated because
- * it will then be replaced with an ILOC or GLOC.
- */
-#undef RECKLESS
-#define CAUTIOUS
-
-/* After looking up a local for the first time, rewrite the
- * code graph, caching its position.
- */
-#define MEMOIZE_LOCALS
-
-/* All the number support there is.
- */
-#define SCM_FLOATS
-#define BIGNUMS
-
-/* GC should relinquish empty cons-pair arenas.
- */
-#define GC_FREE_SEGMENTS
-
-/* Provide a scheme-accessible count-down timer that
- * generates a pseudo-interrupt.
- */
-#define TICKS
-
-
-/* Use engineering notation when converting numbers strings?
- */
-#undef ENGNOT
-
-/* Include support for uniform arrays?
- *
- * Possibly some of the initialization code depends on this
- * being defined, but that is a bug and should be fixed.
- */
-#define ARRAYS
-
-#undef SCM_CAREFUL_INTS
-
-/* {Unsupported Options}
- *
- * These must be defined as given here.
- */
-
-
-#define CCLO
-
-/* Guile Scheme supports the #f/() distinction; Guile Lisp won't. We
- have horrible plans for their unification. */
-#undef SICP
-
-
-
-/* Random options (not yet supported or in final form). */
-
-#define STACK_CHECKING
-#undef NO_CEVAL_STACK_CHECKING
-#undef LONGLONGS
-
-/* Some auto-generated .h files contain unused prototypes
- * that need these typedefs.
- */
-typedef long long_long;
-typedef unsigned long ulong_long;
-
-
-
-/* What did the configure script discover about the outside world? */
-#include "libguile/scmconfig.h"
-
-
-/* Write prototype declarations like this:
- int foo SCM_P ((int a, int b));
- At definitions, use K&R style declarations, but make sure there's a
- declarative prototype (as above) in scope. This will give you
- argument type checking, when available, and be harmless otherwise. */
-#ifdef __STDC__
-# define SCM_P(x) x
-#else
-# define SCM_P(x) ()
-#endif
-
-
-
-/* Define
- *
- * SCM_CHAR_CODE_LIMIT == UCHAR_MAX + 1
- * SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2)
- * SCM_MOST_NEGATIVE_FIXNUM == SCM_SRS((long)LONG_MIN, 2)
- */
-
-#ifdef HAVE_LIMITS_H
-# include <limits.h>
-# ifdef UCHAR_MAX
-# define SCM_CHAR_CODE_LIMIT (UCHAR_MAX+1L)
-# else
-# define SCM_CHAR_CODE_LIMIT 256L
-# endif /* def UCHAR_MAX */
-# define SCM_MOST_POSITIVE_FIXNUM (LONG_MAX>>2)
-# ifdef _UNICOS /* Stupid cray bug */
-# define SCM_MOST_NEGATIVE_FIXNUM ((long)LONG_MIN/4)
-# else
-# define SCM_MOST_NEGATIVE_FIXNUM SCM_SRS((long)LONG_MIN, 2)
-# endif /* UNICOS */
-#else
-# define SCM_CHAR_CODE_LIMIT 256L
-# define SCM_MOST_POSITIVE_FIXNUM ((long)((unsigned long)~0L>>3))
-# if (0 != ~0)
-# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1)
-# else
-# define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM)
-# endif /* (0 != ~0) */
-#endif /* def HAVE_LIMITS_H */
-
-
-#ifdef STDC_HEADERS
-# include <stdlib.h>
-# ifdef AMIGA
-# include <stddef.h>
-# endif /* def AMIGA */
-# define scm_sizet size_t
-#else
-# ifdef _SIZE_T
-# define scm_sizet size_t
-# else
-# define scm_sizet unsigned int
-# endif /* def _SIZE_T */
-#endif /* def STDC_HEADERS */
-
-
-
-#include "libguile/tags.h"
-
-
-#ifdef vms
-# ifndef CHEAP_CONTINUATIONS
- typedef int jmp_buf[17];
- extern int setjump(jmp_buf env);
- extern int longjump(jmp_buf env, int ret);
-# define setjmp setjump
-# define longjmp longjump
-# else
-# include <setjmp.h>
-# endif
-#else /* ndef vms */
-# ifdef _CRAY1
- typedef int jmp_buf[112];
- extern int setjump(jmp_buf env);
- extern int longjump(jmp_buf env, int ret);
-# define setjmp setjump
-# define longjmp longjump
-# else /* ndef _CRAY1 */
-# include <setjmp.h>
-# endif /* ndef _CRAY1 */
-#endif /* ndef vms */
-
-/* James Clark came up with this neat one instruction fix for
- * continuations on the SPARC. It flushes the register windows so
- * that all the state of the process is contained in the stack.
- */
-
-#ifdef sparc
-# define SCM_FLUSH_REGISTER_WINDOWS asm("ta 3")
-#else
-# define SCM_FLUSH_REGISTER_WINDOWS /* empty */
-#endif
-
-/* If stack is not longword aligned then
- */
-
-/* #define SHORT_ALIGN */
-#ifdef THINK_C
-# define SHORT_ALIGN
-#endif
-#ifdef MSDOS
-# define SHORT_ALIGN
-#endif
-#ifdef atarist
-# define SHORT_ALIGN
-#endif
-
-#ifdef SHORT_ALIGN
-typedef short SCM_STACKITEM;
-#else
-typedef long SCM_STACKITEM;
-#endif
-
-
-#ifndef USE_THREADS
-#define SCM_THREAD_DEFER
-#define SCM_THREAD_ALLOW
-#define SCM_THREAD_REDEFER
-#define SCM_THREAD_REALLOW_1
-#define SCM_THREAD_REALLOW_2
-#define SCM_THREAD_SWITCHING_CODE
-#endif
-
-extern unsigned int scm_async_clock;
-#if 0
-#define SCM_ASYNC_TICK \
-{ \
- if (0 == --scm_async_clock) \
- scm_async_click (); \
-} \
-
-#else
-#define SCM_ASYNC_TICK \
-{ \
- if (0 == --scm_async_clock) \
- scm_async_click (); \
- SCM_THREAD_SWITCHING_CODE; \
-} \
-
-#endif
-
-#ifdef SCM_CAREFUL_INTS
-#define SCM_CHECK_NOT_DISABLED \
- if (scm_ints_disabled) \
- fputs("ints already disabled\n", stderr); \
-
-#define SCM_CHECK_NOT_ENABLED \
- if (!scm_ints_disabled) \
- fputs("ints already enabled\n", stderr); \
-
-#else
-#define SCM_CHECK_NOT_DISABLED
-#define SCM_CHECK_NOT_ENABLED
-#endif
-
-
-#define SCM_DEFER_INTS \
-{ \
- SCM_CHECK_NOT_DISABLED; \
- SCM_THREAD_DEFER; \
- scm_ints_disabled = 1; \
-} \
-
-
-#define SCM_ALLOW_INTS_ONLY \
-{ \
- SCM_THREAD_ALLOW; \
- scm_ints_disabled = 0; \
-} \
-
-
-#define SCM_ALLOW_INTS \
-{ \
- SCM_CHECK_NOT_ENABLED; \
- SCM_THREAD_ALLOW; \
- scm_ints_disabled = 0; \
- SCM_ASYNC_TICK; \
-} \
-
-
-#define SCM_REDEFER_INTS \
-{ \
- SCM_THREAD_REDEFER; \
- ++scm_ints_disabled; \
-} \
-
-
-#define SCM_REALLOW_INTS \
-{ \
- SCM_THREAD_REALLOW_1; \
- --scm_ints_disabled; \
- if (!scm_ints_disabled) \
- { \
- SCM_THREAD_REALLOW_2; \
- SCM_ASYNC_TICK; \
- } \
-} \
-
-
-
-
-
-/** SCM_ASSERT
- **
- **/
-
-
-#ifdef SCM_RECKLESS
-#define SCM_ASSERT(_cond, _arg, _pos, _subr)
-#define SCM_ASRTGO(_cond, _label)
-#else
-#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
- if (!(_cond)) \
- scm_wta(_arg, (char *)(_pos), _subr)
-#define SCM_ASRTGO(_cond, _label) \
- if (!(_cond)) \
- goto _label
-#endif
-
-#define SCM_ARGn 0
-#define SCM_ARG1 1
-#define SCM_ARG2 2
-#define SCM_ARG3 3
-#define SCM_ARG4 4
-#define SCM_ARG5 5
- /* #define SCM_ARG6 6
- #define SCM_ARG7 7 */
- /* #define SCM_ARGERR(X) ((X) < SCM_WNA \
- ? (char *)(X) \
- : "wrong type argument")
- */
-
-/* Following must match entry indexes in scm_errmsgs[].
- * Also, SCM_WNA must follow the last SCM_ARGn in sequence.
- */
-#define SCM_WNA 8
- /* #define SCM_OVSCM_FLOW 9 */
-#define SCM_OUTOFRANGE 10
-#define SCM_NALLOC 11
- /* #define SCM_STACK_OVFLOW 12 */
- /* #define SCM_EXIT 13 */
-
-
-/* (...still matching scm_errmsgs) These
- * are signals. Signals may become errors
- * but are distinguished because they first
- * try to invoke a handler that can resume
- * the interrupted routine.
- */
-#define SCM_HUP_SIGNAL 14
-#define SCM_INT_SIGNAL 15
-#define SCM_FPE_SIGNAL 16
-#define SCM_BUS_SIGNAL 17
-#define SCM_SEGV_SIGNAL 18
-#define SCM_ALRM_SIGNAL 19
-#define SCM_GC_SIGNAL 20
-#define SCM_TICK_SIGNAL 21
-
-#define SCM_SIG_ORD(X) ((X) - SCM_HUP_SIGNAL)
-#define SCM_ORD_SIG(X) ((X) + SCM_HUP_SIGNAL)
-#define SCM_NUM_SIGS (SCM_SIG_ORD (SCM_TICK_SIGNAL) + 1)
-
-#if 0
-struct errdesc
-{
- char *msg;
- char *s_response;
- short parent_err;
-};
-
-
-extern struct errdesc scm_errmsgs[];
-#endif
-
-
-
-/* SCM_EXIT_SUCCESS is the default code to return from SCM if no errors
- * were encountered. SCM_EXIT_FAILURE is the default code to return from
- * SCM if errors were encountered. The return code can be explicitly
- * specified in a SCM program with (scm_quit <n>).
- */
-
-#ifndef SCM_EXIT_SUCCESS
-#ifdef vms
-#define SCM_EXIT_SUCCESS 1
-#else
-#define SCM_EXIT_SUCCESS 0
-#endif /* def vms */
-#endif /* ndef SCM_EXIT_SUCCESS */
-#ifndef SCM_EXIT_FAILURE
-#ifdef vms
-#define SCM_EXIT_FAILURE 2
-#else
-#define SCM_EXIT_FAILURE 1
-#endif /* def vms */
-#endif /* ndef SCM_EXIT_FAILURE */
-
-
-
-
-
-#endif /* __SCMH */
diff --git a/libguile/_scm.h b/libguile/_scm.h
deleted file mode 100644
index 88d771a0a..000000000
--- a/libguile/_scm.h
+++ /dev/null
@@ -1,124 +0,0 @@
-/* classes: h_files */
-
-#ifndef _SCMH
-#define _SCMH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "__scm.h"
-
-/* This file is only visible to the libguile sources */
-
-/* Include headers for those files central to the implementation. The
- rest should be explicitly #included in the C files themselves. */
-#include "error.h" /* Everyone signals errors. */
-#include "print.h" /* Everyone needs to print. */
-#include "pairs.h" /* Everyone conses. */
-#include "list.h" /* Everyone makes lists. */
-#include "gc.h" /* Everyone allocates. */
-#include "gsubr.h" /* Everyone defines global functions. */
-#include "procs.h" /* Same. */
-#include "numbers.h" /* Everyone deals with fixnums. */
-#include "symbols.h" /* For length, chars, values, miscellany. */
-#include "boolean.h" /* Everyone wonders about the truth. */
-#include "strings.h" /* Everyone loves string. */
-#include "vectors.h" /* Vectors are used for structures a lot. */
-#include "root.h" /* Everyone uses these objects. */
-#include "ports.h" /* Everyone does I/O. */
-#include "async.h" /* Everyone allows/disallows ints. */
-#ifdef USE_THREADS
-#include "../threads/threads.h" /* Some thread packages does switching
- at async ticks. */
-#endif
-#include "snarf.h" /* Everyone snarfs. */
-
-/* On VMS, GNU C's errno.h contains a special hack to get link attributes
- * for errno correct for linking to the C RTL.
- */
-#include <errno.h>
-
-/* SCM_SYSCALL retries system calls that have been interrupted (EINTR) */
-#ifdef vms
-# ifndef __GNUC__
-# include <ssdef.h>
-# define SCM_SYSCALL(line) do{errno = 0;line;} \
- while(EVMSERR==errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3))
-# endif /* ndef __GNUC__ */
-#endif /* def vms */
-
-#ifndef SCM_SYSCALL
-# ifdef EINTR
-# if (EINTR > 0)
-# define SCM_SYSCALL(line) do{errno = 0;line;}while(EINTR==errno)
-# endif /* (EINTR > 0) */
-# endif /* def EINTR */
-#endif /* ndef SCM_SYSCALL */
-
-#ifndef SCM_SYSCALL
-# define SCM_SYSCALL(line) {line;}
-#endif /* ndef SCM_SYSCALL */
-
-#ifndef MSDOS
-# ifdef ARM_ULIB
- extern volatile int errno;
-# else
- extern int errno;
-# endif /* def ARM_ULIB */
-#endif /* ndef MSDOS */
-#ifdef __TURBOC__
-# if (__TURBOC__==1)
- /* Needed for TURBOC V1.0 */
- extern int errno;
-# endif /* (__TURBOC__==1) */
-#endif /* def __TURBOC__ */
-
-
-
-#ifndef min
-#define min(A,B) ((A) <= (B) ? (A) : (B))
-#endif
-#ifndef max
-#define max(A,B) ((A) >= (B) ? (A) : (B))
-#endif
-
-#endif /* _SCMH */
-
diff --git a/libguile/acconfig.h b/libguile/acconfig.h
deleted file mode 100644
index ded2b044b..000000000
--- a/libguile/acconfig.h
+++ /dev/null
@@ -1,81 +0,0 @@
-/* acconfig.h --- documentation for symbols possibly defined in scmconfig.h
- Jim Blandy <jimb@cyclic.com> --- August 1996 */
-
-/* Define these two if you want support for debugging of Scheme
- programs. */
-#undef DEBUG_EXTENSIONS
-#undef READER_EXTENSIONS
-
-/* Define this if your system has a way to set a stdio stream's file
- descriptor. You should also copy fd.h.in to fd.h, and give the
- macro SET_FILE_FD_FIELD an appropriate definition. See
- configure.in for more details. */
-#undef HAVE_FD_SETTER
-
-/* Define this if your system has a way to set a stdio stream's file
- descriptor. You should also copy fd.h.in to fd.h, and give the
- macro SET_FILE_FD_FIELD an appropriate definition. See
- configure.in for more details. */
-#undef HAVE_FD_SETTER
-
-/* Set this to the name of a field in FILE which contains the number
- of buffered characters waiting to be read. */
-#undef FILE_CNT_FIELD
-
-/* Define this if your stdio has _gptr and _egptr fields which can
- be compared to give the number of buffered characters waiting to
- be read. */
-#undef FILE_CNT_GPTR
-
-/* Define this if your stdio has _IO_read_ptr and _IO_read_end fields
- which can be compared to give the number of buffered characters
- waiting to be read. */
-#undef FILE_CNT_READPTR
-
-/* Define this if your system defines struct linger, for use with the
- getsockopt and setsockopt system calls. */
-#undef HAVE_STRUCT_LINGER
-
-/* Define this if floats are the same size as longs. */
-#undef SCM_SINGLES
-
-/* Define this if a callee's stack frame has a higher address than the
- caller's stack frame. On most machines, this is not the case. */
-#undef SCM_STACK_GROWS_UP
-
-/* Define this if <utime.h> doesn't define struct utimbuf unless
- _POSIX_SOURCE is #defined. See GUILE_STRUCT_UTIMBUF in aclocal.m4. */
-#undef UTIMBUF_NEEDS_POSIX
-
-/* Define this if we should #include <libc.h> when we've already
- #included <unistd.h>. On some systems, they conflict, and libc.h
- should be omitted. See GUILE_HEADER_LIBC_WITH_UNISTD in
- aclocal.m4. */
-#undef LIBC_H_WITH_UNISTD_H
-
-/* Define these to indicate the current version of Guile. These
- values are supposed to be supplied by the configuration system. */
-#undef GUILE_MAJOR_VERSION
-#undef GUILE_MINOR_VERSION
-#undef GUILE_VERSION
-
-/* Define if using cooperative multithreading. */
-#undef USE_COOP_THREADS
-
-/* Define if using "FSU" pthreads. */
-#undef USE_FSU_PTHREADS
-
-/* Define if using MIT pthreads. */
-#undef USE_MIT_PTHREADS
-
-/* Define if using PCthreads pthreads. */
-#undef USE_PCTHREADS_PTHREADS
-
-/* Define if using any sort of threads. */
-#undef USE_THREADS
-
-/* Name of this package. */
-#undef PACKAGE
-
-/* Define if you want support for dynamic linking. */
-#undef DYNAMIC_LINKING
diff --git a/libguile/acinclude.m4 b/libguile/acinclude.m4
deleted file mode 100644
index e69de29bb..000000000
--- a/libguile/acinclude.m4
+++ /dev/null
diff --git a/libguile/aclocal.m4 b/libguile/aclocal.m4
deleted file mode 100644
index 0ddeceb4f..000000000
--- a/libguile/aclocal.m4
+++ /dev/null
@@ -1,240 +0,0 @@
-dnl aclocal.m4 generated automatically by aclocal 1.1l
-
-dnl On the NeXT, #including <utime.h> doesn't give you a definition for
-dnl struct utime, unless you #define _POSIX_SOURCE.
-
-AC_DEFUN(GUILE_STRUCT_UTIMBUF, [
- AC_CACHE_CHECK([whether we need POSIX to get struct utimbuf],
- guile_cv_struct_utimbuf_needs_posix,
- [AC_TRY_CPP([
-#ifdef __EMX__
-#include <sys/utime.h>
-#else
-#include <utime.h>
-#endif
-struct utime blah;
-],
- guile_cv_struct_utimbuf_needs_posix=no,
- guile_cv_struct_utimbuf_needs_posix=yes)])
- if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then
- AC_DEFINE(UTIMBUF_NEEDS_POSIX)
- fi])
-
-
-
-
-dnl
-dnl Apparently, at CMU they have a weird version of libc.h that is
-dnl installed in /usr/local/include and conflicts with unistd.h.
-dnl In these situations, we should not #include libc.h.
-dnl This test arranges to #define LIBC_H_WITH_UNISTD_H iff libc.h is
-dnl present on the system, and is safe to #include.
-dnl
-AC_DEFUN([GUILE_HEADER_LIBC_WITH_UNISTD],
- [
- AC_CHECK_HEADERS(libc.h unistd.h)
- AC_CACHE_CHECK(
- "whether libc.h and unistd.h can be included together",
- guile_cv_header_libc_with_unistd,
- [
- if test "$ac_cv_header_libc_h" = "no"; then
- guile_cv_header_libc_with_unistd="no"
- elif test "$ac_cv_header_unistd.h" = "no"; then
- guile_cv_header_libc_with_unistd="yes"
- else
- AC_TRY_COMPILE(
- [
-# include <libc.h>
-# include <unistd.h>
- ],
- [],
- [guile_cv_header_libc_with_unistd=yes],
- [guile_cv_header_libc_with_unistd=no]
- )
- fi
- ]
- )
- if test "$guile_cv_header_libc_with_unistd" = yes; then
- AC_DEFINE(LIBC_H_WITH_UNISTD_H)
- fi
- ]
-)
-
-# Like AC_CONFIG_HEADER, but automatically create stamp file.
-
-AC_DEFUN(AM_CONFIG_HEADER,
-[AC_PREREQ([2.12])
-AC_CONFIG_HEADER([$1])
-dnl When config.status generates a header, we must update the stamp-h file.
-dnl This file resides in the same directory as the config header
-dnl that is generated. We must strip everything past the first ":",
-dnl and everything past the last "/".
-AC_OUTPUT_COMMANDS(changequote(<<,>>)dnl
-test -z "<<$>>CONFIG_HEADER" || echo timestamp > patsubst(<<$1>>, <<^\([^:]*/\)?.*>>, <<\1>>)stamp-h<<>>dnl
-changequote([,]))])
-
-
-dnl Usage: AM_INIT_GUILE_MODULE(module-name)
-dnl This macro will automatically get the guile version from the
-dnl top-level srcdir, and will initialize automake. It also
-dnl defines the `module' variable.
-AC_DEFUN([AM_INIT_GUILE_MODULE],[
-. $srcdir/../GUILE-VERSION
-AM_INIT_AUTOMAKE($PACKAGE, $VERSION)
-AC_CONFIG_AUX_DIR(..)
-module=[$1]
-AC_SUBST(module)])
-
-# Do all the work for Automake. This macro actually does too much --
-# some checks are only needed if your package does certain things.
-# But this isn't really a big deal.
-
-# serial 1
-
-dnl Usage:
-dnl AM_INIT_AUTOMAKE(package,version)
-
-AC_DEFUN(AM_INIT_AUTOMAKE,
-[AC_REQUIRE([AM_PROG_INSTALL])
-PACKAGE=[$1]
-AC_SUBST(PACKAGE)
-AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE")
-VERSION=[$2]
-AC_SUBST(VERSION)
-AC_DEFINE_UNQUOTED(VERSION, "$VERSION")
-AM_SANITY_CHECK
-AC_ARG_PROGRAM
-AC_PROG_MAKE_SET])
-
-
-# serial 1
-
-AC_DEFUN(AM_PROG_INSTALL,
-[AC_REQUIRE([AC_PROG_INSTALL])
-test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
-AC_SUBST(INSTALL_SCRIPT)dnl
-])
-
-#
-# Check to make sure that the build environment is sane.
-#
-
-AC_DEFUN(AM_SANITY_CHECK,
-[AC_MSG_CHECKING([whether build environment is sane])
-echo timestamp > conftestfile
-# Do this in a subshell so we don't clobber the current shell's
-# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test?
-if (set X `ls -t $srcdir/configure conftestfile`; test "[$]2" = conftestfile)
-then
- # Ok.
- :
-else
- AC_MSG_ERROR([newly created file is older than distributed files!
-Check your system clock])
-fi
-rm -f conftest*
-AC_MSG_RESULT(yes)])
-
-dnl
-dnl CY_AC_WITH_THREADS determines which thread library the user intends
-dnl to put underneath guile. Pass it the path to find the guile top-level
-dnl source directory. Eg CY_AC_WITH_THREADS(../..) for tcl/unix.
-dnl
-
-AC_DEFUN([CY_AC_WITH_THREADS],[
-AC_CACHE_CHECK("threads package type",cy_cv_threads_package,[
-AC_CACHE_VAL(cy_cv_threads_cflags,[
-AC_CACHE_VAL(cy_cv_threads_libs,[
-use_threads=no;
-AC_ARG_WITH(threads,[ --with-threads thread interface],
- use_threads=$withval, use_threads=no)
-test -n "$use_threads" || use_threads=qt
-threads_package=unknown
-if test "$use_threads" != no; then
-dnl
-dnl Test for the qt threads package - used for cooperative threads
-dnl This may not necessarily be built yet - so just check for the
-dnl header files.
-dnl
- if test "$use_threads" = yes || test "$use_threads" = qt; then
- # Look for qt in source directory. This is a hack: we look in
- # "./qt" because this check might be run at the top level.
- if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then
- threads_package=COOP
- cy_cv_threads_cflags="-I$srcdir/../qt -I../qt"
- cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a"
- fi
- else
- if test -f $use_threads/qt.c; then
- # FIXME seems as though we should try to use an installed qt here.
- threads_package=COOP
- cy_cv_threads_cflags="-I$use_threads -I../qt"
- cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a"
- fi
- fi
- if test "$use_threads" = pthreads; then
- # Look for pthreads in srcdir. See above to understand why
- # we always set threads_package.
- if test -f $srcdir/../../pthreads/pthreads/queue.c \
- || test -f $srcdir/../pthreads/pthreads/queue.c; then
- threads_package=MIT
- cy_cv_threads_cflags="-I$srcdir/../../pthreads/include"
- cy_cv_threads_libs="-L../../pthreads/lib -lpthread"
- fi
- fi
- saved_CPP="$CPPFLAGS"
- saved_LD="$LDFLAGS"
- saved_LIBS="$LIBS"
- if test "$threads_package" = unknown; then
-dnl
-dnl Test for the FSU threads package
-dnl
- CPPFLAGS="-I$use_threads/include"
- LDFLAGS="-L$use_threads/lib"
- LIBS="-lgthreads -lmalloc"
- AC_TRY_LINK([#include <pthread.h>],[
-pthread_equal(NULL,NULL);
-], threads_package=FSU)
- fi
- if test "$threads_package" = unknown; then
-dnl
-dnl Test for the MIT threads package
-dnl
- LIBS="-lpthread"
- AC_TRY_LINK([#include <pthread.h>],[
-pthread_equal(NULL,NULL);
-], threads_package=MIT)
- fi
- if test "$threads_package" = unknown; then
-dnl
-dnl Test for the PCthreads package
-dnl
- LIBS="-lpthreads"
- AC_TRY_LINK([#include <pthread.h>],[
-pthread_equal(NULL,NULL);
-], threads_package=PCthreads)
- fi
-dnl
-dnl Set the appropriate flags!
-dnl
- cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags"
- cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs"
- cy_cv_threads_package=$threads_package
- CPPFLAGS="$saved_CPP"
- LDFLAGS="$saved_LD"
- LIBS="$saved_LIBS"
- if test "$threads_package" = unknown; then
- AC_MSG_ERROR("cannot find thread library installation")
- fi
-fi
-])
-])
-],
-dnl
-dnl Set flags according to what is cached.
-dnl
-CPPFLAGS="$cy_cv_threads_cflags"
-LIBS="$cy_cv_threads_libs"
-)
-])
-
diff --git a/libguile/alist.c b/libguile/alist.c
deleted file mode 100644
index 06ede611a..000000000
--- a/libguile/alist.c
+++ /dev/null
@@ -1,380 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include <stdio.h>
-#include "_scm.h"
-#include "eq.h"
-#include "list.h"
-
-#include "alist.h"
-
-
-
-SCM_PROC(s_acons, "acons", 3, 0, 0, scm_acons);
-
-SCM
-scm_acons (w, x, y)
- SCM w;
- SCM x;
- SCM y;
-{
- register SCM z;
- SCM_NEWCELL (z);
- SCM_SETCAR (z, w);
- SCM_SETCDR (z, x);
- x = z;
- SCM_NEWCELL (z);
- SCM_SETCAR (z, x);
- SCM_SETCDR (z, y);
- return z;
-}
-
-
-
-SCM_PROC (s_sloppy_assq, "sloppy-assq", 2, 0, 0, scm_sloppy_assq);
-
-SCM
-scm_sloppy_assq(x, alist)
- SCM x;
- SCM alist;
-{
-
- for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
- {
- SCM tmp = SCM_CAR(alist);
- if (SCM_NIMP (tmp) && SCM_CONSP (tmp) && (SCM_CAR (tmp)==x))
- return tmp;
- }
- return SCM_BOOL_F;
-}
-
-
-
-SCM_PROC (s_sloppy_assv, "sloppy-assv", 2, 0, 0, scm_sloppy_assv);
-
-SCM
-scm_sloppy_assv(x, alist)
- SCM x;
- SCM alist;
-{
- for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
- {
- SCM tmp = SCM_CAR(alist);
- if (SCM_NIMP (tmp)
- && SCM_CONSP (tmp)
- && SCM_NFALSEP (scm_eqv_p (SCM_CAR (tmp), x)))
- return tmp;
- }
- return SCM_BOOL_F;
-}
-
-
-SCM_PROC (s_sloppy_assoc, "sloppy-assoc", 2, 0, 0, scm_sloppy_assoc);
-
-SCM
-scm_sloppy_assoc(x, alist)
- SCM x;
- SCM alist;
-{
- for (; SCM_NIMP (alist) && SCM_CONSP (alist); alist = SCM_CDR (alist))
- {
- SCM tmp = SCM_CAR(alist);
- if (SCM_NIMP (tmp)
- && SCM_CONSP (tmp)
- && SCM_NFALSEP (scm_equal_p (SCM_CAR (tmp), x)))
- return tmp;
- }
- return SCM_BOOL_F;
-}
-
-
-
-
-SCM_PROC(s_assq, "assq", 2, 0, 0, scm_assq);
-
-SCM
-scm_assq(x, alist)
- SCM x;
- SCM alist;
-{
- SCM tmp;
- for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
- SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assq);
- tmp = SCM_CAR(alist);
- SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assq);
- if (SCM_CAR(tmp)==x) return tmp;
- }
- SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assq);
- return SCM_BOOL_F;
-}
-
-
-SCM_PROC(s_assv, "assv", 2, 0, 0, scm_assv);
-
-SCM
-scm_assv(x, alist)
- SCM x;
- SCM alist;
-{
- SCM tmp;
- for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
- SCM_ASRTGO(SCM_CONSP(alist), badlst);
- tmp = SCM_CAR(alist);
- SCM_ASRTGO(SCM_NIMP(tmp) && SCM_CONSP(tmp), badlst);
- if SCM_NFALSEP(scm_eqv_p(SCM_CAR(tmp), x)) return tmp;
- }
-# ifndef RECKLESS
- if (!(SCM_NULLP(alist)))
- badlst: scm_wta(alist, (char *)SCM_ARG2, s_assv);
-# endif
- return SCM_BOOL_F;
-}
-
-
-SCM_PROC(s_assoc, "assoc", 2, 0, 0, scm_assoc);
-
-SCM
-scm_assoc(x, alist)
- SCM x;
- SCM alist;
-{
- SCM tmp;
- for(;SCM_NIMP(alist);alist = SCM_CDR(alist)) {
- SCM_ASSERT(SCM_CONSP(alist), alist, SCM_ARG2, s_assoc);
- tmp = SCM_CAR(alist);
- SCM_ASSERT(SCM_NIMP(tmp) && SCM_CONSP(tmp), alist, SCM_ARG2, s_assoc);
- if SCM_NFALSEP(scm_equal_p(SCM_CAR(tmp), x)) return tmp;
- }
- SCM_ASSERT(SCM_NULLP(alist), alist, SCM_ARG2, s_assoc);
- return SCM_BOOL_F;
-}
-
-
-
-
-SCM_PROC (s_assq_ref, "assq-ref", 2, 0, 0, scm_assq_ref);
-
-SCM
-scm_assq_ref (alist, key)
- SCM alist;
- SCM key;
-{
- SCM handle;
-
- handle = scm_sloppy_assq (key, alist);
- if (SCM_NIMP (handle) && SCM_CONSP (handle))
- {
- return SCM_CDR (handle);
- }
- return SCM_BOOL_F;
-}
-
-
-SCM_PROC (s_assv_ref, "assv-ref", 2, 0, 0, scm_assv_ref);
-
-SCM
-scm_assv_ref (alist, key)
- SCM alist;
- SCM key;
-{
- SCM handle;
-
- handle = scm_sloppy_assv (key, alist);
- if (SCM_NIMP (handle) && SCM_CONSP (handle))
- {
- return SCM_CDR (handle);
- }
- return SCM_BOOL_F;
-}
-
-
-SCM_PROC (s_assoc_ref, "assoc-ref", 2, 0, 0, scm_assoc_ref);
-
-SCM
-scm_assoc_ref (alist, key)
- SCM alist;
- SCM key;
-{
- SCM handle;
-
- handle = scm_sloppy_assoc (key, alist);
- if (SCM_NIMP (handle) && SCM_CONSP (handle))
- {
- return SCM_CDR (handle);
- }
- return SCM_BOOL_F;
-}
-
-
-
-
-
-
-SCM_PROC (s_assq_set_x, "assq-set!", 3, 0, 0, scm_assq_set_x);
-
-SCM
-scm_assq_set_x (alist, key, val)
- SCM alist;
- SCM key;
- SCM val;
-{
- SCM handle;
-
- handle = scm_sloppy_assq (key, alist);
- if (SCM_NIMP (handle) && SCM_CONSP (handle))
- {
- SCM_SETCDR (handle, val);
- return alist;
- }
- else
- return scm_acons (key, val, alist);
-}
-
-SCM_PROC (s_assv_set_x, "assv-set!", 3, 0, 0, scm_assv_set_x);
-
-SCM
-scm_assv_set_x (alist, key, val)
- SCM alist;
- SCM key;
- SCM val;
-{
- SCM handle;
-
- handle = scm_sloppy_assv (key, alist);
- if (SCM_NIMP (handle) && SCM_CONSP (handle))
- {
- SCM_SETCDR (handle, val);
- return alist;
- }
- else
- return scm_acons (key, val, alist);
-}
-
-SCM_PROC (s_assoc_set_x, "assoc-set!", 3, 0, 0, scm_assoc_set_x);
-
-SCM
-scm_assoc_set_x (alist, key, val)
- SCM alist;
- SCM key;
- SCM val;
-{
- SCM handle;
-
- handle = scm_sloppy_assoc (key, alist);
- if (SCM_NIMP (handle) && SCM_CONSP (handle))
- {
- SCM_SETCDR (handle, val);
- return alist;
- }
- else
- return scm_acons (key, val, alist);
-}
-
-
-
-
-SCM_PROC (s_assq_remove_x, "assq-remove!", 2, 0, 0, scm_assq_remove_x);
-
-SCM
-scm_assq_remove_x (alist, key)
- SCM alist;
- SCM key;
-{
- SCM handle;
-
- handle = scm_sloppy_assq (key, alist);
- if (SCM_NIMP (handle) && SCM_CONSP (handle))
- {
- return scm_delq_x (handle, alist);
- }
- else
- return alist;
-}
-
-
-SCM_PROC (s_assv_remove_x, "assv-remove!", 2, 0, 0, scm_assv_remove_x);
-
-SCM
-scm_assv_remove_x (alist, key)
- SCM alist;
- SCM key;
-{
- SCM handle;
-
- handle = scm_sloppy_assv (key, alist);
- if (SCM_NIMP (handle) && SCM_CONSP (handle))
- {
- return scm_delv_x (handle, alist);
- }
- else
- return alist;
-}
-
-
-SCM_PROC (s_assoc_remove_x, "assoc-remove!", 2, 0, 0, scm_assoc_remove_x);
-
-SCM
-scm_assoc_remove_x (alist, key)
- SCM alist;
- SCM key;
-{
- SCM handle;
-
- handle = scm_sloppy_assoc (key, alist);
- if (SCM_NIMP (handle) && SCM_CONSP (handle))
- {
- return scm_delete_x (handle, alist);
- }
- else
- return alist;
-}
-
-
-
-
-
-
-void
-scm_init_alist ()
-{
-#include "alist.x"
-}
-
diff --git a/libguile/alist.h b/libguile/alist.h
deleted file mode 100644
index 87e327fdd..000000000
--- a/libguile/alist.h
+++ /dev/null
@@ -1,69 +0,0 @@
-/* classes: h_files */
-
-#ifndef ALISTH
-#define ALISTH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-extern SCM scm_acons SCM_P ((SCM w, SCM x, SCM y));
-extern SCM scm_sloppy_assq SCM_P ((SCM x, SCM alist));
-extern SCM scm_sloppy_assv SCM_P ((SCM x, SCM alist));
-extern SCM scm_sloppy_assoc SCM_P ((SCM x, SCM alist));
-extern SCM scm_assq SCM_P ((SCM x, SCM alist));
-extern SCM scm_assv SCM_P ((SCM x, SCM alist));
-extern SCM scm_assoc SCM_P ((SCM x, SCM alist));
-extern SCM scm_assq_ref SCM_P ((SCM alist, SCM key));
-extern SCM scm_assv_ref SCM_P ((SCM alist, SCM key));
-extern SCM scm_assoc_ref SCM_P ((SCM alist, SCM key));
-extern SCM scm_assq_set_x SCM_P ((SCM alist, SCM key, SCM val));
-extern SCM scm_assv_set_x SCM_P ((SCM alist, SCM key, SCM val));
-extern SCM scm_assoc_set_x SCM_P ((SCM alist, SCM key, SCM val));
-extern SCM scm_assq_remove_x SCM_P ((SCM alist, SCM key));
-extern SCM scm_assv_remove_x SCM_P ((SCM alist, SCM key));
-extern SCM scm_assoc_remove_x SCM_P ((SCM alist, SCM key));
-extern void scm_init_alist SCM_P ((void));
-
-#endif /* ALISTH */
diff --git a/libguile/append.c b/libguile/append.c
deleted file mode 100644
index 204d57ab8..000000000
--- a/libguile/append.c
+++ /dev/null
@@ -1,78 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "list.h"
-
-#include "append.h"
-
-
-
-SCM_PROC (s_append, "append", 0, 0, 1, scm_append);
-
-SCM
-scm_append (objs)
- SCM objs;
-{
- return scm_list_append (objs);
-}
-
-
-SCM_PROC (s_append_x, "append!", 0, 0, 1, scm_append_x);
-
-SCM
-scm_append_x (objs)
- SCM objs;
-{
- return scm_list_append_x (objs);
-}
-
-
-
-
-void
-scm_init_append ()
-{
-#include "append.x"
-}
-
diff --git a/libguile/append.h b/libguile/append.h
deleted file mode 100644
index 9c13d6356..000000000
--- a/libguile/append.h
+++ /dev/null
@@ -1,55 +0,0 @@
-/* classes: h_files */
-
-#ifndef APPENDH
-#define APPENDH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-extern SCM scm_append SCM_P ((SCM objs));
-extern SCM scm_append_x SCM_P ((SCM objs));
-extern void scm_init_append SCM_P ((void));
-
-#endif /* APPENDH */
diff --git a/libguile/appinit.c b/libguile/appinit.c
deleted file mode 100644
index 1dff367f3..000000000
--- a/libguile/appinit.c
+++ /dev/null
@@ -1,52 +0,0 @@
-/* Copyright (C) 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-
-
-
-
-void
-scm_appinit ()
-{
-}
diff --git a/libguile/arbiters.c b/libguile/arbiters.c
deleted file mode 100644
index 292f4fec1..000000000
--- a/libguile/arbiters.c
+++ /dev/null
@@ -1,133 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "smob.h"
-
-#include "arbiters.h"
-
-
-/* {Arbiters}
- *
- * These procedures implement synchronization primitives. Processors
- * with an atomic test-and-set instruction can use it here (and not
- * SCM_DEFER_INTS).
- */
-
-static long scm_tc16_arbiter;
-
-
-static int
-prinarb (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_gen_puts (scm_regular_string, "#<arbiter ", port);
- if (SCM_CAR (exp) & (1L << 16))
- scm_gen_puts (scm_regular_string, "locked ", port);
- scm_iprin1 (SCM_CDR (exp), port, pstate);
- scm_gen_putc ('>', port);
- return !0;
-}
-
-static scm_smobfuns arbsmob =
-{
- scm_markcdr, scm_free0, prinarb, 0
-};
-
-SCM_PROC(s_make_arbiter, "make-arbiter", 1, 0, 0, scm_make_arbiter);
-
-SCM
-scm_make_arbiter (name)
- SCM name;
-{
- register SCM z;
- SCM_NEWCELL (z);
- SCM_SETCDR (z, name);
- SCM_SETCAR (z, scm_tc16_arbiter);
- return z;
-}
-
-SCM_PROC(s_try_arbiter, "try-arbiter", 1, 0, 0, scm_try_arbiter);
-
-SCM
-scm_try_arbiter (arb)
- SCM arb;
-{
- SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_try_arbiter);
- SCM_DEFER_INTS;
- if (SCM_CAR (arb) & (1L << 16))
- arb = SCM_BOOL_F;
- else
- {
- SCM_SETCAR (arb, scm_tc16_arbiter | (1L << 16));
- arb = SCM_BOOL_T;
- }
- SCM_ALLOW_INTS;
- return arb;
-}
-
-
-SCM_PROC(s_release_arbiter, "release-arbiter", 1, 0, 0, scm_release_arbiter);
-
-SCM
-scm_release_arbiter (arb)
- SCM arb;
-{
- SCM_ASSERT ((SCM_TYP16 (arb) == scm_tc16_arbiter), arb, SCM_ARG1, s_release_arbiter);
- if (!(SCM_CAR (arb) & (1L << 16)))
- return SCM_BOOL_F;
- SCM_SETCAR (arb, scm_tc16_arbiter);
- return SCM_BOOL_T;
-}
-
-
-
-void
-scm_init_arbiters ()
-{
- scm_tc16_arbiter = scm_newsmob (&arbsmob);
-#include "arbiters.x"
-}
-
diff --git a/libguile/arbiters.h b/libguile/arbiters.h
deleted file mode 100644
index 5e34ce297..000000000
--- a/libguile/arbiters.h
+++ /dev/null
@@ -1,56 +0,0 @@
-/* classes: h_files */
-
-#ifndef ARBITERSH
-#define ARBITERSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-extern SCM scm_make_arbiter SCM_P ((SCM name));
-extern SCM scm_try_arbiter SCM_P ((SCM arb));
-extern SCM scm_release_arbiter SCM_P ((SCM arb));
-extern void scm_init_arbiters SCM_P ((void));
-
-#endif /* ARBITERSH */
diff --git a/libguile/async.c b/libguile/async.c
deleted file mode 100644
index d2478fd65..000000000
--- a/libguile/async.c
+++ /dev/null
@@ -1,674 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include <signal.h>
-#include "_scm.h"
-#include "eval.h"
-#include "throw.h"
-#include "smob.h"
-
-#include "async.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-
-
-/* {Asynchronous Events}
- *
- *
- * Async == thunk + mark.
- *
- * Setting the mark guarantees future execution of the thunk. More
- * than one set may be satisfied by a single execution.
- *
- * scm_tick_clock decremented once per SCM_ALLOW_INTS.
- * Async execution triggered by SCM_ALLOW_INTS when scm_tick_clock drops to 0.
- * Async execution prevented by scm_mask_ints != 0.
- *
- * If the clock reaches 0 when scm_mask_ints != 0, then reset the clock
- * to 1.
- *
- * If the clock reaches 0 any other time, run marked asyncs.
- *
- * From a unix signal handler, mark a corresponding async and set the clock
- * to 1. Do SCM_REDEFER_INTS;/SCM_REALLOW_INTS so that if the signal handler is not
- * called in the dynamic scope of a critical section, it is excecuted immediately.
- *
- * Overall, closely timed signals of a particular sort may be combined. Pending signals
- * are delivered in a fixed priority order, regardless of arrival order.
- *
- */
-
-
-
-unsigned int scm_async_clock = 20;
-static unsigned int scm_async_rate = 20;
-unsigned int scm_mask_ints = 1;
-
-static unsigned int scm_tick_clock = 0;
-static unsigned int scm_tick_rate = 0;
-static unsigned int scm_desired_tick_rate = 0;
-static unsigned int scm_switch_clock = 0;
-static unsigned int scm_switch_rate = 0;
-static unsigned int scm_desired_switch_rate = 0;
-
-static SCM system_signal_asyncs[SCM_NUM_SIGS];
-static SCM handler_var;
-static SCM symbol_signal;
-
-
-struct scm_async
-{
- int got_it; /* needs to be delivered? */
- SCM thunk; /* the handler. */
-};
-
-
-static long scm_tc16_async;
-
-#define SCM_ASYNCP(X) (scm_tc16_async == SCM_GCTYP16 (X))
-#define SCM_ASYNC(X) ((struct scm_async *)SCM_CDR (X))
-
-
-
-
-
-
-static int asyncs_pending SCM_P ((void));
-
-static int
-asyncs_pending ()
-{
- SCM pos;
- pos = scm_asyncs;
- while (pos != SCM_EOL)
- {
- SCM a;
- struct scm_async * it;
- a = SCM_CAR (pos);
- it = SCM_ASYNC (a);
- if (it->got_it)
- return 1;
- pos = SCM_CDR (pos);
- }
- return 0;
-}
-
-
-
-void
-scm_async_click ()
-{
- int owe_switch;
- int owe_tick;
-
- if (!scm_switch_rate)
- {
- owe_switch = 0;
- scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
- scm_desired_switch_rate = 0;
- }
- else
- {
- owe_switch = (scm_async_rate >= scm_switch_clock);
- if (owe_switch)
- {
- if (scm_desired_switch_rate)
- {
- scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
- scm_desired_switch_rate = 0;
- }
- else
- scm_switch_clock = scm_switch_rate;
- }
- else
- {
- if (scm_desired_switch_rate)
- {
- scm_switch_clock = scm_switch_rate = scm_desired_switch_rate;
- scm_desired_switch_rate = 0;
- }
- else
- scm_switch_clock -= scm_async_rate;
- }
- }
-
- if (scm_mask_ints)
- {
- if (owe_switch)
- scm_switch ();
- scm_async_clock = 1;
- return;;
- }
-
- if (!scm_tick_rate)
- {
- unsigned int r;
- owe_tick = 0;
- r = scm_desired_tick_rate;
- if (r)
- {
- scm_desired_tick_rate = 0;
- scm_tick_rate = r;
- scm_tick_clock = r;
- }
- }
- else
- {
- owe_tick = (scm_async_rate >= scm_tick_clock);
- if (owe_tick)
- {
- scm_tick_clock = scm_tick_rate = scm_desired_tick_rate;
- scm_desired_tick_rate = 0;
- }
- else
- {
- if (scm_desired_tick_rate)
- {
- scm_tick_clock = scm_tick_rate = scm_desired_tick_rate;
- scm_desired_tick_rate = 0;
- }
- else
- scm_tick_clock -= scm_async_rate;
- }
- }
-
- if (owe_tick)
- scm_async_mark (system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)]);
-
- SCM_DEFER_INTS;
- if (scm_tick_rate && scm_switch_rate)
- {
- scm_async_rate = min (scm_tick_clock, scm_switch_clock);
- scm_async_clock = scm_async_rate;
- }
- else if (scm_tick_rate)
- {
- scm_async_clock = scm_async_rate = scm_tick_clock;
- }
- else if (scm_switch_rate)
- {
- scm_async_clock = scm_async_rate = scm_switch_clock;
- }
- else
- scm_async_clock = scm_async_rate = 1 << 16;
- SCM_ALLOW_INTS_ONLY;
-
- tail:
- scm_run_asyncs (scm_asyncs);
-
- SCM_DEFER_INTS;
- if (asyncs_pending ())
- {
- SCM_ALLOW_INTS_ONLY;
- goto tail;
- }
- SCM_ALLOW_INTS;
-
- if (owe_switch)
- scm_switch ();
-}
-
-
-
-
-
-void
-scm_switch ()
-{
-#if 0 /* Thread switching code should probably reside here, but the
- async switching code doesn't seem to work, so it's put in the
- SCM_ASYNC_TICK macro instead. /mdj */
- SCM_THREAD_SWITCHING_CODE;
-#endif
-}
-
-
-
-static void scm_deliver_signal SCM_P ((int num));
-
-static void
-scm_deliver_signal (num)
- int num;
-{
- SCM handler;
- handler = SCM_CDR (handler_var);
- if (handler != SCM_BOOL_F)
- scm_apply (handler, SCM_MAKINUM (num), scm_listofnull);
- else
- {
- scm_mask_ints = 0;
- scm_throw (symbol_signal,
- scm_listify (SCM_MAKINUM (num), SCM_UNDEFINED));
- }
-}
-
-
-
-
-
-static int print_async SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-
-static int
-print_async (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_gen_puts (scm_regular_string, "#<async ", port);
- scm_intprint(exp, 16, port);
- scm_gen_putc('>', port);
- return 1;
-}
-
-
-static SCM mark_async SCM_P ((SCM obj));
-
-static SCM
-mark_async (obj)
- SCM obj;
-{
- struct scm_async * it;
- if (SCM_GC8MARKP (obj))
- return SCM_BOOL_F;
- SCM_SETGC8MARK (obj);
- it = SCM_ASYNC (obj);
- return it->thunk;
-}
-
-
-static scm_sizet free_async SCM_P ((SCM obj));
-
-static scm_sizet
-free_async (obj)
- SCM obj;
-{
- struct scm_async * it;
- it = SCM_ASYNC (obj);
- scm_must_free ((char *)it);
- return (sizeof (*it));
-}
-
-
-static scm_smobfuns async_smob =
-{
- mark_async,
- free_async,
- print_async,
- 0
-};
-
-
-
-
-SCM_PROC(s_async, "async", 1, 0, 0, scm_async);
-
-SCM
-scm_async (thunk)
- SCM thunk;
-{
- SCM it;
- struct scm_async * async;
-
- SCM_NEWCELL (it);
- SCM_DEFER_INTS;
- SCM_SETCDR (it, SCM_EOL);
- async = (struct scm_async *)scm_must_malloc (sizeof (*async), s_async);
- async->got_it = 0;
- async->thunk = thunk;
- SCM_SETCDR (it, (SCM)async);
- SCM_SETCAR (it, (SCM)scm_tc16_async);
- SCM_ALLOW_INTS;
- return it;
-}
-
-SCM_PROC(s_system_async, "system-async", 1, 0, 0, scm_system_async);
-
-SCM
-scm_system_async (thunk)
- SCM thunk;
-{
- SCM it;
- SCM list;
-
- it = scm_async (thunk);
- SCM_NEWCELL (list);
- SCM_DEFER_INTS;
- SCM_SETCAR (list, it);
- SCM_SETCDR (list, scm_asyncs);
- scm_asyncs = list;
- SCM_ALLOW_INTS;
- return it;
-}
-
-SCM_PROC(s_async_mark, "async-mark", 1, 0, 0, scm_async_mark);
-
-SCM
-scm_async_mark (a)
- SCM a;
-{
- struct scm_async * it;
- SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark);
- it = SCM_ASYNC (a);
- it->got_it = 1;
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_system_async_mark, "system-async-mark", 1, 0, 0, scm_system_async_mark);
-
-SCM
-scm_system_async_mark (a)
- SCM a;
-{
- struct scm_async * it;
- SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_async_mark);
- it = SCM_ASYNC (a);
- SCM_REDEFER_INTS;
- it->got_it = 1;
- scm_async_rate = 1 + scm_async_rate - scm_async_clock;
- scm_async_clock = 1;
- SCM_REALLOW_INTS;
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_run_asyncs, "run-asyncs", 1, 0, 0, scm_run_asyncs);
-
-SCM
-scm_run_asyncs (list_of_a)
- SCM list_of_a;
-{
- SCM pos;
-
- if (scm_mask_ints)
- return SCM_BOOL_F;
- pos = list_of_a;
- while (pos != SCM_EOL)
- {
- SCM a;
- struct scm_async * it;
- SCM_ASSERT (SCM_NIMP (pos) && SCM_CONSP (pos), pos, SCM_ARG1, s_run_asyncs);
- a = SCM_CAR (pos);
- SCM_ASSERT (SCM_NIMP (a) && SCM_ASYNCP (a), a, SCM_ARG1, s_run_asyncs);
- it = SCM_ASYNC (a);
- scm_mask_ints = 1;
- if (it->got_it)
- {
- it->got_it = 0;
- scm_apply (it->thunk, SCM_EOL, SCM_EOL);
- }
- scm_mask_ints = 0;
- pos = SCM_CDR (pos);
- }
- return SCM_BOOL_T;
-}
-
-
-
-
-SCM_PROC(s_noop, "noop", 0, 0, 1, scm_noop);
-
-SCM
-scm_noop (args)
- SCM args;
-{
- return (SCM_NULLP (args)
- ? SCM_BOOL_F
- : SCM_CAR (args));
-}
-
-
-
-
-SCM_PROC(s_set_tick_rate, "set-tick-rate", 1, 0, 0, scm_set_tick_rate);
-
-SCM
-scm_set_tick_rate (n)
- SCM n;
-{
- unsigned int old_n;
- SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_tick_rate);
- old_n = scm_tick_rate;
- scm_desired_tick_rate = SCM_INUM (n);
- scm_async_rate = 1 + scm_async_rate - scm_async_clock;
- scm_async_clock = 1;
- return SCM_MAKINUM (old_n);
-}
-
-
-
-
-SCM_PROC(s_set_switch_rate, "set-switch-rate", 1, 0, 0, scm_set_switch_rate);
-
-SCM
-scm_set_switch_rate (n)
- SCM n;
-{
- unsigned int old_n;
- SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_set_switch_rate);
- old_n = scm_switch_rate;
- scm_desired_switch_rate = SCM_INUM (n);
- scm_async_rate = 1 + scm_async_rate - scm_async_clock;
- scm_async_clock = 1;
- return SCM_MAKINUM (old_n);
-}
-
-
-
-
-static SCM scm_sys_hup_async_thunk SCM_P ((void));
-
-static SCM
-scm_sys_hup_async_thunk ()
-{
- scm_deliver_signal (SCM_HUP_SIGNAL);
- return SCM_BOOL_F;
-}
-
-
-static SCM scm_sys_int_async_thunk SCM_P ((void));
-
-static SCM
-scm_sys_int_async_thunk ()
-{
- scm_deliver_signal (SCM_INT_SIGNAL);
- return SCM_BOOL_F;
-}
-
-
-static SCM scm_sys_fpe_async_thunk SCM_P ((void));
-
-static SCM
-scm_sys_fpe_async_thunk ()
-{
- scm_deliver_signal (SCM_FPE_SIGNAL);
- return SCM_BOOL_F;
-}
-
-
-static SCM scm_sys_bus_async_thunk SCM_P ((void));
-
-static SCM
-scm_sys_bus_async_thunk ()
-{
- scm_deliver_signal (SCM_BUS_SIGNAL);
- return SCM_BOOL_F;
-}
-
-
-static SCM scm_sys_segv_async_thunk SCM_P ((void));
-
-static SCM
-scm_sys_segv_async_thunk ()
-{
- scm_deliver_signal (SCM_SEGV_SIGNAL);
- return SCM_BOOL_F;
-}
-
-
-static SCM scm_sys_alrm_async_thunk SCM_P ((void));
-
-static SCM
-scm_sys_alrm_async_thunk ()
-{
- scm_deliver_signal (SCM_ALRM_SIGNAL);
- return SCM_BOOL_F;
-}
-
-
-static SCM scm_sys_gc_async_thunk SCM_P ((void));
-
-static SCM
-scm_sys_gc_async_thunk ()
-{
- scm_deliver_signal (SCM_GC_SIGNAL);
- return SCM_BOOL_F;
-}
-
-
-static SCM scm_sys_tick_async_thunk SCM_P ((void));
-
-static SCM
-scm_sys_tick_async_thunk ()
-{
- scm_deliver_signal (SCM_TICK_SIGNAL);
- return SCM_BOOL_F;
-}
-
-
-
-
-
-
-SCM
-scm_take_signal (n)
- int n;
-{
- SCM ignored;
- if (!scm_ints_disabled)
- {
- /* For reasons of speed, the SCM_NEWCELL macro doesn't defer
- interrupts. Instead, it first sets its argument to point to
- the first cell in the list, and then advances the freelist
- pointer to the next cell. Now, if this procedure is
- interrupted, the only anomalous state possible is to have
- both SCM_NEWCELL's argument and scm_freelist pointing to the
- same cell. To deal with this case, we always throw away the
- first cell in scm_freelist here.
-
- At least, that's the theory. I'm not convinced that that's
- the only anomalous path we need to worry about. */
- SCM_NEWCELL (ignored);
- }
- scm_system_async_mark (system_signal_asyncs[SCM_SIG_ORD(n)]);
- return SCM_BOOL_F;
-}
-
-
-
-SCM_PROC(s_unmask_signals, "unmask-signals", 0, 0, 0, scm_unmask_signals);
-
-SCM
-scm_unmask_signals ()
-{
- scm_mask_ints = 0;
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_mask_signals, "mask-signals", 0, 0, 0, scm_mask_signals);
-
-SCM
-scm_mask_signals ()
-{
- scm_mask_ints = 1;
- return SCM_UNSPECIFIED;
-}
-
-
-
-
-void
-scm_init_async ()
-{
- SCM a_thunk;
- scm_tc16_async = scm_newsmob (&async_smob);
- symbol_signal = SCM_CAR (scm_sysintern ("signal", SCM_UNDEFINED));
- scm_permanent_object (symbol_signal);
-
- /* These are in the opposite order of delivery priortity.
- *
- * Error conditions are given low priority:
- */
- a_thunk = scm_make_gsubr ("%hup-thunk", 0, 0, 0, scm_sys_hup_async_thunk);
- system_signal_asyncs[SCM_SIG_ORD(SCM_HUP_SIGNAL)] = scm_system_async (a_thunk);
- a_thunk = scm_make_gsubr ("%int-thunk", 0, 0, 0, scm_sys_int_async_thunk);
- system_signal_asyncs[SCM_SIG_ORD(SCM_INT_SIGNAL)] = scm_system_async (a_thunk);
- a_thunk = scm_make_gsubr ("%fpe-thunk", 0, 0, 0, scm_sys_fpe_async_thunk);
- system_signal_asyncs[SCM_SIG_ORD(SCM_FPE_SIGNAL)] = scm_system_async (a_thunk);
- a_thunk = scm_make_gsubr ("%bus-thunk", 0, 0, 0, scm_sys_bus_async_thunk);
- system_signal_asyncs[SCM_SIG_ORD(SCM_BUS_SIGNAL)] = scm_system_async (a_thunk);
- a_thunk = scm_make_gsubr ("%segv-thunk", 0, 0, 0, scm_sys_segv_async_thunk);
- system_signal_asyncs[SCM_SIG_ORD(SCM_SEGV_SIGNAL)] = scm_system_async (a_thunk);
-
-
- a_thunk = scm_make_gsubr ("%gc-thunk", 0, 0, 0, scm_sys_gc_async_thunk);
- system_signal_asyncs[SCM_SIG_ORD(SCM_GC_SIGNAL)] = scm_system_async (a_thunk);
-
- /* Clock and PC driven conditions are given highest priority. */
- a_thunk = scm_make_gsubr ("%tick-thunk", 0, 0, 0, scm_sys_tick_async_thunk);
- system_signal_asyncs[SCM_SIG_ORD(SCM_TICK_SIGNAL)] = scm_system_async (a_thunk);
- a_thunk = scm_make_gsubr ("%alrm-thunk", 0, 0, 0, scm_sys_alrm_async_thunk);
- system_signal_asyncs[SCM_SIG_ORD(SCM_ALRM_SIGNAL)] = scm_system_async (a_thunk);
-
- handler_var = scm_sysintern ("signal-handler", SCM_UNDEFINED);
- SCM_SETCDR (handler_var, SCM_BOOL_F);
- scm_permanent_object (handler_var);
-#include "async.x"
-}
diff --git a/libguile/async.h b/libguile/async.h
deleted file mode 100644
index 217603ba6..000000000
--- a/libguile/async.h
+++ /dev/null
@@ -1,71 +0,0 @@
-/* classes: h_files */
-
-#ifndef ASYNCH
-#define ASYNCH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-
-extern unsigned int scm_mask_ints;
-
-
-
-extern void scm_async_click SCM_P ((void));
-extern void scm_switch SCM_P ((void));
-extern SCM scm_async SCM_P ((SCM thunk));
-extern SCM scm_system_async SCM_P ((SCM thunk));
-extern SCM scm_async_mark SCM_P ((SCM a));
-extern SCM scm_system_async_mark SCM_P ((SCM a));
-extern SCM scm_run_asyncs SCM_P ((SCM list_of_a));
-extern SCM scm_noop SCM_P ((SCM args));
-extern SCM scm_set_tick_rate SCM_P ((SCM n));
-extern SCM scm_set_switch_rate SCM_P ((SCM n));
-extern SCM scm_take_signal SCM_P ((int n));
-extern SCM scm_unmask_signals SCM_P ((void));
-extern SCM scm_mask_signals SCM_P ((void));
-extern void scm_init_async SCM_P ((void));
-
-#endif /* ASYNCH */
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
deleted file mode 100644
index 365b6ca58..000000000
--- a/libguile/backtrace.c
+++ /dev/null
@@ -1,436 +0,0 @@
-/* Printing of backtraces and error messages
- * Copyright (C) 1996 Mikael Djurfeldt
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- *
- * The author can be reached at djurfeldt@nada.kth.se
- * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
- */
-
-#include <stdio.h>
-#include "_scm.h"
-#include "stacks.h"
-#include "srcprop.h"
-#include "genio.h"
-#include "struct.h"
-#include "strports.h"
-
-#include "backtrace.h"
-
-/* {Error reporting and backtraces}
- * (A first approximation.)
- *
- * Note that these functions shouldn't generate errors themselves.
- */
-
-#ifndef SCM_RECKLESS
-#undef SCM_ASSERT
-#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
- if (!(_cond)) \
- return SCM_BOOL_F;
-#endif
-
-static void display_header SCM_P ((SCM source, SCM port));
-static void
-display_header (source, port)
- SCM source;
- SCM port;
-{
- SCM fname = (SCM_NIMP (source) && SCM_MEMOIZEDP (source)
- ? scm_source_property (source, scm_i_filename)
- : SCM_BOOL_F);
- if (SCM_NIMP (fname) && SCM_STRINGP (fname))
- {
- scm_prin1 (fname, port, 0);
- scm_gen_putc (':', port);
- scm_prin1 (scm_source_property (source, scm_i_line), port, 0);
- scm_gen_putc (':', port);
- scm_prin1 (scm_source_property (source, scm_i_column), port, 0);
- }
- else
- scm_gen_puts (scm_regular_string, "ERROR", port);
- scm_gen_puts (scm_regular_string, ": ", port);
-}
-
-
-void
-scm_display_error_message (message, args, port)
- SCM message;
- SCM args;
- SCM port;
-{
- int writingp;
- char *start;
- char *p;
-
- if (!SCM_STRINGP (message) || SCM_IMP (args) || !scm_list_p (args))
- {
- scm_prin1 (message, port, 0);
- scm_gen_putc ('\n', port);
- return;
- }
-
- start = SCM_CHARS (message);
- for (p = start; *p != '\0'; ++p)
- if (*p == '%')
- {
- if (SCM_IMP (args) || SCM_NCONSP (args))
- continue;
-
- ++p;
- if (*p == 's')
- writingp = 0;
- else if (*p == 'S')
- writingp = 1;
- else
- continue;
-
- scm_gen_write (scm_regular_string, start, p - start - 1, port);
- scm_prin1 (SCM_CAR (args), port, writingp);
- args = SCM_CDR (args);
- start = p + 1;
- }
- scm_gen_write (scm_regular_string, start, p - start, port);
- scm_gen_putc ('\n', port);
-}
-
-static void display_expression SCM_P ((SCM frame, SCM pname, SCM source, SCM port));
-static void
-display_expression (frame, pname, source, port)
- SCM frame;
- SCM pname;
- SCM source;
- SCM port;
-{
- SCM print_state = scm_make_print_state ();
- scm_print_state *pstate = SCM_PRINT_STATE (print_state);
- pstate->writingp = 0;
- pstate->fancyp = 1;
- pstate->level = 2;
- pstate->length = 3;
- if (SCM_NIMP (pname) && SCM_ROSTRINGP (pname))
- {
- if (SCM_NIMP (frame)
- && SCM_FRAMEP (frame)
- && SCM_FRAME_EVAL_ARGS_P (frame))
- scm_gen_puts (scm_regular_string, "While evaluating arguments to ", port);
- else
- scm_gen_puts (scm_regular_string, "In procedure ", port);
- scm_iprin1 (pname, port, pstate);
- if (SCM_NIMP (source) && SCM_MEMOIZEDP (source))
- {
- scm_gen_puts (scm_regular_string, " in expression ", port);
- pstate->writingp = 1;
- scm_iprin1 (scm_unmemoize (source), port, pstate);
- }
- }
- else if (SCM_NIMP (source))
- {
- scm_gen_puts (scm_regular_string, "In expression ", port);
- pstate->writingp = 1;
- scm_iprin1 (scm_unmemoize (source), port, pstate);
- }
- scm_gen_puts (scm_regular_string, ":\n", port);
- scm_free_print_state (print_state);
-}
-
-SCM_PROC(s_display_error, "display-error", 6, 0, 0, scm_display_error);
-SCM
-scm_display_error (stack, port, subr, message, args, rest)
- SCM stack;
- SCM port;
- SCM subr;
- SCM message;
- SCM args;
- SCM rest;
-{
- SCM current_frame = SCM_BOOL_F;
- SCM source = SCM_BOOL_F;
- SCM pname = SCM_BOOL_F;
- if (SCM_DEBUGGINGP
- && SCM_NIMP (stack)
- && SCM_STACKP (stack)
- && SCM_STACK_LENGTH (stack) > 0)
- {
- current_frame = scm_stack_ref (stack, SCM_INUM0);
- source = SCM_FRAME_SOURCE (current_frame);
- if (!(SCM_NIMP (source) && SCM_MEMOIZEDP (source)))
- source = SCM_FRAME_SOURCE (SCM_FRAME_PREV (current_frame));
- if (SCM_FRAME_PROC_P (current_frame)
- && scm_procedure_p (SCM_FRAME_PROC (current_frame)) == SCM_BOOL_T)
- pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
- }
- if (!(SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
- pname = subr;
- if ((SCM_NIMP (source) && SCM_MEMOIZEDP (source))
- || (SCM_NIMP (pname) && SCM_ROSTRINGP (pname)))
- {
- display_header (source, port);
- display_expression (current_frame, pname, source, port);
- }
- display_header (source, port);
- scm_display_error_message (message, args, port);
- return SCM_UNSPECIFIED;
-}
-
-static void indent SCM_P ((int n, SCM port));
-static void
-indent (n, port)
- int n;
- SCM port;
-{
- int i;
- for (i = 0; i < n; ++i)
- scm_gen_putc (' ', port);
-}
-
-static void display_frame_expr SCM_P ((char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate));
-static void
-display_frame_expr (hdr, exp, tlr, indentation, sport, port, pstate)
- char *hdr;
- SCM exp;
- char *tlr;
- int indentation;
- SCM sport;
- SCM port;
- scm_print_state *pstate;
-{
- pstate->level = 2;
- pstate->length = 3;
- if (SCM_NIMP (exp) && SCM_CONSP (exp))
- {
- scm_iprlist (hdr, exp, tlr[0], port, pstate);
- scm_gen_puts (scm_regular_string, &tlr[1], port);
- }
- else
- scm_iprin1 (exp, port, pstate);
- scm_gen_putc ('\n', port);
-}
-
-static void display_frame SCM_P ((SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate));
-static void
-display_frame (frame, nfield, indentation, sport, port, pstate)
- SCM frame;
- int nfield;
- int indentation;
- SCM sport;
- SCM port;
- scm_print_state *pstate;
-{
- int n, i, j;
-
- /* Announce missing frames? */
- if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
- {
- indent (nfield + 1 + indentation, port);
- scm_gen_puts (scm_regular_string, "...\n", port);
- }
-
- /* Check size of frame number. */
- n = SCM_FRAME_NUMBER (frame);
- for (i = 0, j = n; j > 0; ++i) j /= 10;
-
- /* Number indentation. */
- indent (nfield - (i ? i : 1), port);
-
- /* Frame number. */
- scm_iprin1 (SCM_MAKINUM (n), port, pstate);
-
- /* Real frame marker */
- scm_gen_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
-
- /* Indentation. */
- indent (indentation, port);
-
- if (SCM_FRAME_PROC_P (frame))
- /* Display an application. */
- {
- SCM proc = SCM_FRAME_PROC (frame);
- SCM name = (SCM_NFALSEP (scm_procedure_p (proc))
- ? scm_procedure_name (proc)
- : SCM_BOOL_F);
- display_frame_expr ("[",
- scm_cons (SCM_NFALSEP (name) ? name : proc,
- SCM_FRAME_ARGS (frame)),
- SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
- nfield + 1 + indentation,
- sport,
- port,
- pstate);
- }
- else
- /* Display a special form. */
- {
- SCM source = SCM_FRAME_SOURCE (frame);
- SCM copy = scm_source_property (source, scm_i_copy);
- display_frame_expr ("(",
- SCM_NIMP (copy) && SCM_CONSP (copy)
- ? copy
- : scm_unmemoize (source),
- ")",
- nfield + 1 + indentation,
- sport,
- port,
- pstate);
- }
-
- /* Announce missing frames? */
- if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
- {
- indent (nfield + 1 + indentation, port);
- scm_gen_puts (scm_regular_string, "...\n", port);
- }
-}
-
-SCM_PROC(s_display_backtrace, "display-backtrace", 2, 2, 0, scm_display_backtrace);
-SCM
-scm_display_backtrace (stack, port, first, depth)
- SCM stack;
- SCM port;
- SCM first;
- SCM depth;
-{
- int n_frames, beg, end, n, i, j;
- int nfield, indent_p, indentation;
- SCM frame, sport, print_state;
- scm_print_state *pstate;
-
- /* Argument checking and extraction. */
- SCM_ASSERT (SCM_NIMP (stack) && SCM_STACKP (stack),
- stack,
- SCM_ARG1,
- s_display_backtrace);
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port),
- port,
- SCM_ARG2,
- s_display_backtrace);
- n_frames = SCM_INUM (scm_stack_length (stack));
- n = SCM_INUMP (depth) ? SCM_INUM (depth) : SCM_BACKTRACE_DEPTH;
- if (SCM_BACKWARDS_P)
- {
- beg = SCM_INUMP (first) ? SCM_INUM (first) : 0;
- end = beg + n - 1;
- if (end >= n_frames)
- end = n_frames - 1;
- n = end - beg + 1;
- }
- else
- {
- if (SCM_INUMP (first))
- {
- beg = SCM_INUM (first);
- end = beg - n + 1;
- if (end < 0)
- end = 0;
- }
- else
- {
- beg = n - 1;
- end = 0;
- if (beg >= n_frames)
- beg = n_frames - 1;
- }
- n = beg - end + 1;
- }
- SCM_ASSERT (beg >= 0 && beg < n_frames, first, SCM_ARG3, s_display_backtrace);
- SCM_ASSERT (n > 0, depth, SCM_ARG4, s_display_backtrace);
-
- /* Create a string port used for adaptation of printing parameters. */
- sport = scm_mkstrport (SCM_INUM0,
- scm_make_string (SCM_MAKINUM (240), SCM_UNDEFINED),
- SCM_OPN | SCM_WRTNG,
- s_display_backtrace);
-
- /* Create a print state for printing of frames. */
- print_state = scm_make_print_state ();
- pstate = SCM_PRINT_STATE (print_state);
- pstate->writingp = 1;
- pstate->fancyp = 1;
-
- /* First find out if it's reasonable to do indentation. */
- if (SCM_BACKWARDS_P)
- indent_p = 0;
- else
- {
- indent_p = 1;
- frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
- for (i = 0, j = 0; i < n; ++i)
- {
- if (SCM_FRAME_REAL_P (frame))
- ++j;
- if (j > SCM_BACKTRACE_INDENT)
- {
- indent_p = 0;
- break;
- }
- frame = (SCM_BACKWARDS_P
- ? SCM_FRAME_PREV (frame)
- : SCM_FRAME_NEXT (frame));
- }
- }
-
- /* Determine size of frame number field. */
- j = SCM_FRAME_NUMBER (scm_stack_ref (stack, SCM_MAKINUM (end)));
- for (i = 0; j > 0; ++i) j /= 10;
- nfield = i ? i : 1;
-
- scm_gen_puts (scm_regular_string, "Backtrace:\n", port);
-
- /* Print frames. */
- frame = scm_stack_ref (stack, SCM_MAKINUM (beg));
- indentation = 1;
- display_frame (frame, nfield, indentation, sport, port, pstate);
- for (i = 1; i < n; ++i)
- {
- if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
- ++indentation;
- frame = SCM_BACKWARDS_P ? SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame);
- display_frame (frame, nfield, indentation, sport, port, pstate);
- }
-
- return SCM_UNSPECIFIED;
-}
-
-
-
-void
-scm_init_backtrace ()
-{
-#include "backtrace.x"
-}
diff --git a/libguile/backtrace.h b/libguile/backtrace.h
deleted file mode 100644
index 830a1eb2a..000000000
--- a/libguile/backtrace.h
+++ /dev/null
@@ -1,58 +0,0 @@
-/* classes: h_files */
-
-#ifndef BACKTRACEH
-#define BACKTRACEH
-/* Copyright (C) 1996 Mikael Djurfeldt
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- *
- * The author can be reached at djurfeldt@nada.kth.se
- * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
- */
-
-
-#include "libguile/__scm.h"
-
-void scm_display_error_message SCM_P ((SCM message, SCM args, SCM port));
-SCM scm_display_error SCM_P ((SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest));
-SCM scm_display_backtrace SCM_P ((SCM stack, SCM port, SCM first, SCM depth));
-
-void scm_init_backtrace SCM_P ((void));
-
-#endif /* BACKTRACEH */
diff --git a/libguile/boolean.c b/libguile/boolean.c
deleted file mode 100644
index 3267f28eb..000000000
--- a/libguile/boolean.c
+++ /dev/null
@@ -1,78 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-
-#include "boolean.h"
-
-
-
-SCM_PROC(s_not, "not", 1, 0, 0, scm_not);
-
-SCM
-scm_not(x)
- SCM x;
-{
- return SCM_FALSEP(x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-SCM_PROC(s_boolean_p, "boolean?", 1, 0, 0, scm_boolean_p);
-
-SCM
-scm_boolean_p(obj)
- SCM obj;
-{
- if (SCM_BOOL_F==obj) return SCM_BOOL_T;
- if (SCM_BOOL_T==obj) return SCM_BOOL_T;
- return SCM_BOOL_F;
-}
-
-
-
-void
-scm_init_boolean ()
-{
-#include "boolean.x"
-}
-
diff --git a/libguile/boolean.h b/libguile/boolean.h
deleted file mode 100644
index c9945e566..000000000
--- a/libguile/boolean.h
+++ /dev/null
@@ -1,67 +0,0 @@
-/* classes: h_files */
-
-#ifndef BOOLEANH
-#define BOOLEANH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-
-/* Boolean Values
- *
- */
-#define SCM_FALSEP(x) (SCM_BOOL_F == (x))
-#define SCM_NFALSEP(x) (SCM_BOOL_F != (x))
-
-/* SCM_BOOL_NOT returns the other boolean.
- * The order of ^s here is important for Borland C++ (!?!?!)
- */
-#define SCM_BOOL_NOT(x) ((x) ^ (SCM_BOOL_T ^ SCM_BOOL_F))
-
-
-
-extern SCM scm_not SCM_P ((SCM x));
-extern SCM scm_boolean_p SCM_P ((SCM obj));
-extern void scm_init_boolean SCM_P ((void));
-
-#endif /* BOOLEANH */
diff --git a/libguile/chars.c b/libguile/chars.c
deleted file mode 100644
index cc77d3d09..000000000
--- a/libguile/chars.c
+++ /dev/null
@@ -1,408 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include <ctype.h>
-#include "_scm.h"
-
-#include "chars.h"
-
-
-
-
-SCM_PROC(s_char_p, "char?", 1, 0, 0, scm_char_p);
-
-SCM
-scm_char_p(x)
- SCM x;
-{
- return SCM_ICHRP(x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC1 (s_char_eq_p, "char=?", scm_tc7_rpsubr, scm_char_eq_p);
-
-SCM
-scm_char_eq_p(x, y)
- SCM x;
- SCM y;
-{
- SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_eq_p);
- SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_eq_p);
- return (SCM_ICHR(x) == SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-SCM_PROC1 (s_char_less_p, "char<?", scm_tc7_rpsubr, scm_char_less_p);
-
-SCM
-scm_char_less_p(x, y)
- SCM x;
- SCM y;
-{
- SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_less_p);
- SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_less_p);
- return (SCM_ICHR(x) < SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC1 (s_char_leq_p, "char<=?", scm_tc7_rpsubr, scm_char_leq_p);
-
-SCM
-scm_char_leq_p(x, y)
- SCM x;
- SCM y;
-{
- SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_leq_p);
- SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_leq_p);
- return (SCM_ICHR(x) <= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC1 (s_char_gr_p, "char>?", scm_tc7_rpsubr, scm_char_gr_p);
-
-SCM
-scm_char_gr_p(x, y)
- SCM x;
- SCM y;
-{
- SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_gr_p);
- SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_gr_p);
- return (SCM_ICHR(x) > SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC1 (s_char_geq_p, "char>=?", scm_tc7_rpsubr, scm_char_geq_p);
-
-SCM
-scm_char_geq_p(x, y)
- SCM x;
- SCM y;
-{
- SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_geq_p);
- SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_geq_p);
- return (SCM_ICHR(x) >= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC1 (s_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, scm_char_ci_eq_p);
-
-SCM
-scm_char_ci_eq_p(x, y)
- SCM x;
- SCM y;
-{
- SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_eq_p);
- SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_eq_p);
- return (scm_upcase(SCM_ICHR(x))==scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC1 (s_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr, scm_char_ci_less_p);
-
-SCM
-scm_char_ci_less_p(x, y)
- SCM x;
- SCM y;
-{
- SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_less_p);
- SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_less_p);
- return (scm_upcase(SCM_ICHR(x)) < scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC1 (s_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr, scm_char_ci_leq_p);
-
-SCM
-scm_char_ci_leq_p(x, y)
- SCM x;
- SCM y;
-{
- SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_leq_p);
- SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_leq_p);
- return (scm_upcase(SCM_ICHR(x)) <= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC1 (s_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, scm_char_ci_gr_p);
-
-SCM
-scm_char_ci_gr_p(x, y)
- SCM x;
- SCM y;
-{
- SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_gr_p);
- SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_gr_p);
- return (scm_upcase(SCM_ICHR(x)) > scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC1 (s_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, scm_char_ci_geq_p);
-
-SCM
-scm_char_ci_geq_p(x, y)
- SCM x;
- SCM y;
-{
- SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_geq_p);
- SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_geq_p);
- return (scm_upcase(SCM_ICHR(x)) >= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-SCM_PROC(s_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, scm_char_alphabetic_p);
-
-SCM
-scm_char_alphabetic_p(chr)
- SCM chr;
-{
- SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_alphabetic_p);
- return (isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_char_numeric_p, "char-numeric?", 1, 0, 0, scm_char_numeric_p);
-
-SCM
-scm_char_numeric_p(chr)
- SCM chr;
-{
- SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_numeric_p);
- return (isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_char_whitespace_p, "char-whitespace?", 1, 0, 0, scm_char_whitespace_p);
-
-SCM
-scm_char_whitespace_p(chr)
- SCM chr;
-{
- SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_whitespace_p);
- return (isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-
-SCM_PROC(s_char_upper_case_p, "char-upper-case?", 1, 0, 0, scm_char_upper_case_p);
-
-SCM
-scm_char_upper_case_p(chr)
- SCM chr;
-{
- SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p);
- return (isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-SCM_PROC(s_char_lower_case_p, "char-lower-case?", 1, 0, 0, scm_char_lower_case_p);
-
-SCM
-scm_char_lower_case_p(chr)
- SCM chr;
-{
- SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_lower_case_p);
- return (isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-
-SCM_PROC (s_char_is_both_p, "char-is-both?", 1, 0, 0, scm_char_is_both_p);
-
-SCM
-scm_char_is_both_p (chr)
- SCM chr;
-{
- SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p);
- return ((isascii(SCM_ICHR(chr)) && (isupper(SCM_ICHR(chr)) || islower(SCM_ICHR(chr))))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-
-
-SCM_PROC(s_char_to_integer, "char->integer", 1, 0, 0, scm_char_to_integer);
-
-SCM
-scm_char_to_integer(chr)
- SCM chr;
-{
- SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_to_integer);
- return scm_ulong2num((unsigned long)SCM_ICHR(chr));
-}
-
-
-
-SCM_PROC(s_integer_to_char, "integer->char", 1, 0, 0, scm_integer_to_char);
-
-SCM
-scm_integer_to_char(n)
- SCM n;
-{
- unsigned long ni;
-
- ni = 0xffff & scm_num2ulong (n, (char *)SCM_ARG1, s_integer_to_char);
- return SCM_MAKICHR(SCM_INUM(n));
-}
-
-
-SCM_PROC(s_char_upcase, "char-upcase", 1, 0, 0, scm_char_upcase);
-
-SCM
-scm_char_upcase(chr)
- SCM chr;
-{
- SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upcase);
- return SCM_MAKICHR(scm_upcase(SCM_ICHR(chr)));
-}
-
-
-SCM_PROC(s_char_downcase, "char-downcase", 1, 0, 0, scm_char_downcase);
-
-SCM
-scm_char_downcase(chr)
- SCM chr;
-{
- SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_downcase);
- return SCM_MAKICHR(scm_downcase(SCM_ICHR(chr)));
-}
-
-
-
-
-
-static unsigned char scm_upcase_table[SCM_CHAR_CODE_LIMIT];
-static unsigned char scm_downcase_table[SCM_CHAR_CODE_LIMIT];
-static unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz";
-static unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
-
-
-void
-scm_tables_prehistory ()
-{
- int i;
- for (i = 0; i < SCM_CHAR_CODE_LIMIT; i++)
- scm_upcase_table[i] = scm_downcase_table[i] = i;
- for (i = 0; i < sizeof scm_lowers / sizeof (char); i++)
- {
- scm_upcase_table[scm_lowers[i]] = scm_uppers[i];
- scm_downcase_table[scm_uppers[i]] = scm_lowers[i];
- }
-}
-
-
-int
-scm_upcase (c)
- unsigned int c;
-{
- if (c < sizeof (scm_upcase_table))
- return scm_upcase_table[c];
- else
- return c;
-}
-
-
-int
-scm_downcase (c)
- unsigned int c;
-{
- if (c < sizeof (scm_downcase_table))
- return scm_downcase_table[c];
- else
- return c;
-}
-
-
-#ifdef _DCC
-# define ASCII
-#else
-# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301'))
-# define EBCDIC
-# endif /* (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */
-# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101'))
-# define ASCII
-# endif /* (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */
-#endif /* def _DCC */
-
-
-#ifdef EBCDIC
-char *scm_charnames[] =
-{
- "nul","soh","stx","etx", "pf", "ht", "lc","del",
- 0 , 0 ,"smm", "vt", "ff", "cr", "so", "si",
- "dle","dc1","dc2","dc3","res", "nl", "bs", "il",
- "can", "em", "cc", 0 ,"ifs","igs","irs","ius",
- "ds","sos", "fs", 0 ,"byp", "lf","eob","pre",
- 0 , 0 , "sm", 0 , 0 ,"enq","ack","bel",
- 0 , 0 ,"syn", 0 , "pn", "rs", "uc","eot",
- 0 , 0 , 0 , 0 ,"dc4","nak", 0 ,"sub",
- "space", scm_s_newline, "tab", "backspace", "return", "page", "null"};
-
-char scm_charnums[] =
-"\000\001\002\003\004\005\006\007\
-\010\011\012\013\014\015\016\017\
-\020\021\022\023\024\025\026\027\
-\030\031\032\033\034\035\036\037\
-\040\041\042\043\044\045\046\047\
-\050\051\052\053\054\055\056\057\
-\060\061\062\063\064\065\066\067\
-\070\071\072\073\074\075\076\077\
- \n\t\b\r\f\0";
-#endif /* def EBCDIC */
-#ifdef ASCII
-char *scm_charnames[] =
-{
- "nul","soh","stx","etx","eot","enq","ack","bel",
- "bs", "ht", "nl", "vt", "np", "cr", "so", "si",
- "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
- "can", "em","sub","esc", "fs", "gs", "rs", "us",
- "space", "newline", "tab", "backspace", "return", "page", "null", "del"};
-char scm_charnums[] =
-"\000\001\002\003\004\005\006\007\
-\010\011\012\013\014\015\016\017\
-\020\021\022\023\024\025\026\027\
-\030\031\032\033\034\035\036\037\
- \n\t\b\r\f\0\177";
-#endif /* def ASCII */
-
-int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *);
-
-
-
-
-
-void
-scm_init_chars ()
-{
-#include "chars.x"
-}
-
diff --git a/libguile/chars.h b/libguile/chars.h
deleted file mode 100644
index 8ad7672d3..000000000
--- a/libguile/chars.h
+++ /dev/null
@@ -1,90 +0,0 @@
-/* classes: h_files */
-
-#ifndef SCM_CHARSH
-#define SCM_CHARSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-/* Immediate Characters
- */
-#define SCM_ICHRP(x) (SCM_ITAG8(x) == scm_tc8_char)
-#define SCM_ICHR(x) ((unsigned int)SCM_ITAG8_DATA(x))
-#define SCM_MAKICHR(x) SCM_MAKE_ITAG8(x, scm_tc8_char)
-
-
-
-extern char *scm_charnames[];
-extern int scm_n_charnames;
-extern char scm_charnums[];
-
-
-
-extern SCM scm_char_p SCM_P ((SCM x));
-extern SCM scm_char_eq_p SCM_P ((SCM x, SCM y));
-extern SCM scm_char_less_p SCM_P ((SCM x, SCM y));
-extern SCM scm_char_leq_p SCM_P ((SCM x, SCM y));
-extern SCM scm_char_gr_p SCM_P ((SCM x, SCM y));
-extern SCM scm_char_geq_p SCM_P ((SCM x, SCM y));
-extern SCM scm_char_ci_eq_p SCM_P ((SCM x, SCM y));
-extern SCM scm_char_ci_less_p SCM_P ((SCM x, SCM y));
-extern SCM scm_char_ci_leq_p SCM_P ((SCM x, SCM y));
-extern SCM scm_char_ci_gr_p SCM_P ((SCM x, SCM y));
-extern SCM scm_char_ci_geq_p SCM_P ((SCM x, SCM y));
-extern SCM scm_char_alphabetic_p SCM_P ((SCM chr));
-extern SCM scm_char_numeric_p SCM_P ((SCM chr));
-extern SCM scm_char_whitespace_p SCM_P ((SCM chr));
-extern SCM scm_char_upper_case_p SCM_P ((SCM chr));
-extern SCM scm_char_lower_case_p SCM_P ((SCM chr));
-extern SCM scm_char_is_both_p SCM_P ((SCM chr));
-extern SCM scm_char_to_integer SCM_P ((SCM chr));
-extern SCM scm_integer_to_char SCM_P ((SCM n));
-extern SCM scm_char_upcase SCM_P ((SCM chr));
-extern SCM scm_char_downcase SCM_P ((SCM chr));
-extern void scm_tables_prehistory SCM_P ((void));
-extern int scm_upcase SCM_P ((unsigned int c));
-extern int scm_downcase SCM_P ((unsigned int c));
-extern void scm_init_chars SCM_P ((void));
-
-#endif /* SCM_CHARSH */
diff --git a/libguile/configure b/libguile/configure
deleted file mode 100755
index e156c59b0..000000000
--- a/libguile/configure
+++ /dev/null
@@ -1,3057 +0,0 @@
-#! /bin/sh
-
-# Guess values for system-dependent variables and create Makefiles.
-# Generated automatically using autoconf version 2.12
-# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
-#
-# This configure script is free software; the Free Software Foundation
-# gives unlimited permission to copy, distribute and modify it.
-
-# Defaults:
-ac_help=
-ac_default_prefix=/usr/local
-# Any additions from configure.in:
-ac_help="$ac_help
- --disable-debug Don't include debugging support"
-ac_help="$ac_help
- --enable-dynamic-linking Include support for dynamic linking"
-ac_help="$ac_help
- --with-threads thread interface"
-
-# Initialize some variables set by options.
-# The variables have the same names as the options, with
-# dashes changed to underlines.
-build=NONE
-cache_file=./config.cache
-exec_prefix=NONE
-host=NONE
-no_create=
-nonopt=NONE
-no_recursion=
-prefix=NONE
-program_prefix=NONE
-program_suffix=NONE
-program_transform_name=s,x,x,
-silent=
-site=
-srcdir=
-target=NONE
-verbose=
-x_includes=NONE
-x_libraries=NONE
-bindir='${exec_prefix}/bin'
-sbindir='${exec_prefix}/sbin'
-libexecdir='${exec_prefix}/libexec'
-datadir='${prefix}/share'
-sysconfdir='${prefix}/etc'
-sharedstatedir='${prefix}/com'
-localstatedir='${prefix}/var'
-libdir='${exec_prefix}/lib'
-includedir='${prefix}/include'
-oldincludedir='/usr/include'
-infodir='${prefix}/info'
-mandir='${prefix}/man'
-
-# Initialize some other variables.
-subdirs=
-MFLAGS= MAKEFLAGS=
-# Maximum number of lines to put in a shell here document.
-ac_max_here_lines=12
-
-ac_prev=
-for ac_option
-do
-
- # If the previous option needs an argument, assign it.
- if test -n "$ac_prev"; then
- eval "$ac_prev=\$ac_option"
- ac_prev=
- continue
- fi
-
- case "$ac_option" in
- -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
- *) ac_optarg= ;;
- esac
-
- # Accept the important Cygnus configure options, so we can diagnose typos.
-
- case "$ac_option" in
-
- -bindir | --bindir | --bindi | --bind | --bin | --bi)
- ac_prev=bindir ;;
- -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
- bindir="$ac_optarg" ;;
-
- -build | --build | --buil | --bui | --bu)
- ac_prev=build ;;
- -build=* | --build=* | --buil=* | --bui=* | --bu=*)
- build="$ac_optarg" ;;
-
- -cache-file | --cache-file | --cache-fil | --cache-fi \
- | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
- ac_prev=cache_file ;;
- -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
- | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
- cache_file="$ac_optarg" ;;
-
- -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
- ac_prev=datadir ;;
- -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
- | --da=*)
- datadir="$ac_optarg" ;;
-
- -disable-* | --disable-*)
- ac_feature=`echo $ac_option|sed -e 's/-*disable-//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then
- { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
- fi
- ac_feature=`echo $ac_feature| sed 's/-/_/g'`
- eval "enable_${ac_feature}=no" ;;
-
- -enable-* | --enable-*)
- ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then
- { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
- fi
- ac_feature=`echo $ac_feature| sed 's/-/_/g'`
- case "$ac_option" in
- *=*) ;;
- *) ac_optarg=yes ;;
- esac
- eval "enable_${ac_feature}='$ac_optarg'" ;;
-
- -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
- | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
- | --exec | --exe | --ex)
- ac_prev=exec_prefix ;;
- -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
- | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
- | --exec=* | --exe=* | --ex=*)
- exec_prefix="$ac_optarg" ;;
-
- -gas | --gas | --ga | --g)
- # Obsolete; use --with-gas.
- with_gas=yes ;;
-
- -help | --help | --hel | --he)
- # Omit some internal or obsolete options to make the list less imposing.
- # This message is too long to be a string in the A/UX 3.1 sh.
- cat << EOF
-Usage: configure [options] [host]
-Options: [defaults in brackets after descriptions]
-Configuration:
- --cache-file=FILE cache test results in FILE
- --help print this message
- --no-create do not create output files
- --quiet, --silent do not print \`checking...' messages
- --version print the version of autoconf that created configure
-Directory and file names:
- --prefix=PREFIX install architecture-independent files in PREFIX
- [$ac_default_prefix]
- --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
- [same as prefix]
- --bindir=DIR user executables in DIR [EPREFIX/bin]
- --sbindir=DIR system admin executables in DIR [EPREFIX/sbin]
- --libexecdir=DIR program executables in DIR [EPREFIX/libexec]
- --datadir=DIR read-only architecture-independent data in DIR
- [PREFIX/share]
- --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc]
- --sharedstatedir=DIR modifiable architecture-independent data in DIR
- [PREFIX/com]
- --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var]
- --libdir=DIR object code libraries in DIR [EPREFIX/lib]
- --includedir=DIR C header files in DIR [PREFIX/include]
- --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include]
- --infodir=DIR info documentation in DIR [PREFIX/info]
- --mandir=DIR man documentation in DIR [PREFIX/man]
- --srcdir=DIR find the sources in DIR [configure dir or ..]
- --program-prefix=PREFIX prepend PREFIX to installed program names
- --program-suffix=SUFFIX append SUFFIX to installed program names
- --program-transform-name=PROGRAM
- run sed PROGRAM on installed program names
-EOF
- cat << EOF
-Host type:
- --build=BUILD configure for building on BUILD [BUILD=HOST]
- --host=HOST configure for HOST [guessed]
- --target=TARGET configure for TARGET [TARGET=HOST]
-Features and packages:
- --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
- --enable-FEATURE[=ARG] include FEATURE [ARG=yes]
- --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
- --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
- --x-includes=DIR X include files are in DIR
- --x-libraries=DIR X library files are in DIR
-EOF
- if test -n "$ac_help"; then
- echo "--enable and --with options recognized:$ac_help"
- fi
- exit 0 ;;
-
- -host | --host | --hos | --ho)
- ac_prev=host ;;
- -host=* | --host=* | --hos=* | --ho=*)
- host="$ac_optarg" ;;
-
- -includedir | --includedir | --includedi | --included | --include \
- | --includ | --inclu | --incl | --inc)
- ac_prev=includedir ;;
- -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
- | --includ=* | --inclu=* | --incl=* | --inc=*)
- includedir="$ac_optarg" ;;
-
- -infodir | --infodir | --infodi | --infod | --info | --inf)
- ac_prev=infodir ;;
- -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
- infodir="$ac_optarg" ;;
-
- -libdir | --libdir | --libdi | --libd)
- ac_prev=libdir ;;
- -libdir=* | --libdir=* | --libdi=* | --libd=*)
- libdir="$ac_optarg" ;;
-
- -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
- | --libexe | --libex | --libe)
- ac_prev=libexecdir ;;
- -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
- | --libexe=* | --libex=* | --libe=*)
- libexecdir="$ac_optarg" ;;
-
- -localstatedir | --localstatedir | --localstatedi | --localstated \
- | --localstate | --localstat | --localsta | --localst \
- | --locals | --local | --loca | --loc | --lo)
- ac_prev=localstatedir ;;
- -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
- | --localstate=* | --localstat=* | --localsta=* | --localst=* \
- | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
- localstatedir="$ac_optarg" ;;
-
- -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
- ac_prev=mandir ;;
- -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
- mandir="$ac_optarg" ;;
-
- -nfp | --nfp | --nf)
- # Obsolete; use --without-fp.
- with_fp=no ;;
-
- -no-create | --no-create | --no-creat | --no-crea | --no-cre \
- | --no-cr | --no-c)
- no_create=yes ;;
-
- -no-recursion | --no-recursion | --no-recursio | --no-recursi \
- | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
- no_recursion=yes ;;
-
- -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
- | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
- | --oldin | --oldi | --old | --ol | --o)
- ac_prev=oldincludedir ;;
- -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
- | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
- | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
- oldincludedir="$ac_optarg" ;;
-
- -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
- ac_prev=prefix ;;
- -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
- prefix="$ac_optarg" ;;
-
- -program-prefix | --program-prefix | --program-prefi | --program-pref \
- | --program-pre | --program-pr | --program-p)
- ac_prev=program_prefix ;;
- -program-prefix=* | --program-prefix=* | --program-prefi=* \
- | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
- program_prefix="$ac_optarg" ;;
-
- -program-suffix | --program-suffix | --program-suffi | --program-suff \
- | --program-suf | --program-su | --program-s)
- ac_prev=program_suffix ;;
- -program-suffix=* | --program-suffix=* | --program-suffi=* \
- | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
- program_suffix="$ac_optarg" ;;
-
- -program-transform-name | --program-transform-name \
- | --program-transform-nam | --program-transform-na \
- | --program-transform-n | --program-transform- \
- | --program-transform | --program-transfor \
- | --program-transfo | --program-transf \
- | --program-trans | --program-tran \
- | --progr-tra | --program-tr | --program-t)
- ac_prev=program_transform_name ;;
- -program-transform-name=* | --program-transform-name=* \
- | --program-transform-nam=* | --program-transform-na=* \
- | --program-transform-n=* | --program-transform-=* \
- | --program-transform=* | --program-transfor=* \
- | --program-transfo=* | --program-transf=* \
- | --program-trans=* | --program-tran=* \
- | --progr-tra=* | --program-tr=* | --program-t=*)
- program_transform_name="$ac_optarg" ;;
-
- -q | -quiet | --quiet | --quie | --qui | --qu | --q \
- | -silent | --silent | --silen | --sile | --sil)
- silent=yes ;;
-
- -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
- ac_prev=sbindir ;;
- -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
- | --sbi=* | --sb=*)
- sbindir="$ac_optarg" ;;
-
- -sharedstatedir | --sharedstatedir | --sharedstatedi \
- | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
- | --sharedst | --shareds | --shared | --share | --shar \
- | --sha | --sh)
- ac_prev=sharedstatedir ;;
- -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
- | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
- | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
- | --sha=* | --sh=*)
- sharedstatedir="$ac_optarg" ;;
-
- -site | --site | --sit)
- ac_prev=site ;;
- -site=* | --site=* | --sit=*)
- site="$ac_optarg" ;;
-
- -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
- ac_prev=srcdir ;;
- -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
- srcdir="$ac_optarg" ;;
-
- -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
- | --syscon | --sysco | --sysc | --sys | --sy)
- ac_prev=sysconfdir ;;
- -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
- | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
- sysconfdir="$ac_optarg" ;;
-
- -target | --target | --targe | --targ | --tar | --ta | --t)
- ac_prev=target ;;
- -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
- target="$ac_optarg" ;;
-
- -v | -verbose | --verbose | --verbos | --verbo | --verb)
- verbose=yes ;;
-
- -version | --version | --versio | --versi | --vers)
- echo "configure generated by autoconf version 2.12"
- exit 0 ;;
-
- -with-* | --with-*)
- ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then
- { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
- fi
- ac_package=`echo $ac_package| sed 's/-/_/g'`
- case "$ac_option" in
- *=*) ;;
- *) ac_optarg=yes ;;
- esac
- eval "with_${ac_package}='$ac_optarg'" ;;
-
- -without-* | --without-*)
- ac_package=`echo $ac_option|sed -e 's/-*without-//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then
- { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
- fi
- ac_package=`echo $ac_package| sed 's/-/_/g'`
- eval "with_${ac_package}=no" ;;
-
- --x)
- # Obsolete; use --with-x.
- with_x=yes ;;
-
- -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
- | --x-incl | --x-inc | --x-in | --x-i)
- ac_prev=x_includes ;;
- -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
- | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
- x_includes="$ac_optarg" ;;
-
- -x-libraries | --x-libraries | --x-librarie | --x-librari \
- | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
- ac_prev=x_libraries ;;
- -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
- | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
- x_libraries="$ac_optarg" ;;
-
- -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; }
- ;;
-
- *)
- if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then
- echo "configure: warning: $ac_option: invalid host type" 1>&2
- fi
- if test "x$nonopt" != xNONE; then
- { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; }
- fi
- nonopt="$ac_option"
- ;;
-
- esac
-done
-
-if test -n "$ac_prev"; then
- { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; }
-fi
-
-trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
-
-# File descriptor usage:
-# 0 standard input
-# 1 file creation
-# 2 errors and warnings
-# 3 some systems may open it to /dev/tty
-# 4 used on the Kubota Titan
-# 6 checking for... messages and results
-# 5 compiler messages saved in config.log
-if test "$silent" = yes; then
- exec 6>/dev/null
-else
- exec 6>&1
-fi
-exec 5>./config.log
-
-echo "\
-This file contains any messages produced by compilers while
-running configure, to aid debugging if configure makes a mistake.
-" 1>&5
-
-# Strip out --no-create and --no-recursion so they do not pile up.
-# Also quote any args containing shell metacharacters.
-ac_configure_args=
-for ac_arg
-do
- case "$ac_arg" in
- -no-create | --no-create | --no-creat | --no-crea | --no-cre \
- | --no-cr | --no-c) ;;
- -no-recursion | --no-recursion | --no-recursio | --no-recursi \
- | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;;
- *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*)
- ac_configure_args="$ac_configure_args '$ac_arg'" ;;
- *) ac_configure_args="$ac_configure_args $ac_arg" ;;
- esac
-done
-
-# NLS nuisances.
-# Only set these to C if already set. These must not be set unconditionally
-# because not all systems understand e.g. LANG=C (notably SCO).
-# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'!
-# Non-C LC_CTYPE values break the ctype check.
-if test "${LANG+set}" = set; then LANG=C; export LANG; fi
-if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
-if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi
-if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi
-
-# confdefs.h avoids OS command line length limits that DEFS can exceed.
-rm -rf conftest* confdefs.h
-# AIX cpp loses on an empty file, so make sure it contains at least a newline.
-echo > confdefs.h
-
-# A filename unique to this package, relative to the directory that
-# configure is in, which we can look for to find out if srcdir is correct.
-ac_unique_file=eval.c
-
-# Find the source files, if location was not specified.
-if test -z "$srcdir"; then
- ac_srcdir_defaulted=yes
- # Try the directory containing this script, then its parent.
- ac_prog=$0
- ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'`
- test "x$ac_confdir" = "x$ac_prog" && ac_confdir=.
- srcdir=$ac_confdir
- if test ! -r $srcdir/$ac_unique_file; then
- srcdir=..
- fi
-else
- ac_srcdir_defaulted=no
-fi
-if test ! -r $srcdir/$ac_unique_file; then
- if test "$ac_srcdir_defaulted" = yes; then
- { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; }
- else
- { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; }
- fi
-fi
-srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'`
-
-# Prefer explicitly selected file to automatically selected ones.
-if test -z "$CONFIG_SITE"; then
- if test "x$prefix" != xNONE; then
- CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
- else
- CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
- fi
-fi
-for ac_site_file in $CONFIG_SITE; do
- if test -r "$ac_site_file"; then
- echo "loading site script $ac_site_file"
- . "$ac_site_file"
- fi
-done
-
-if test -r "$cache_file"; then
- echo "loading cache $cache_file"
- . $cache_file
-else
- echo "creating cache $cache_file"
- > $cache_file
-fi
-
-ac_ext=c
-# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
-ac_cpp='$CPP $CPPFLAGS'
-ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
-ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
-cross_compiling=$ac_cv_prog_cc_cross
-
-if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
- # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
- if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then
- ac_n= ac_c='
-' ac_t=' '
- else
- ac_n=-n ac_c= ac_t=
- fi
-else
- ac_n= ac_c='\c' ac_t=
-fi
-
-
-
-
-
-ac_aux_dir=
-for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do
- if test -f $ac_dir/install-sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install-sh -c"
- break
- elif test -f $ac_dir/install.sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install.sh -c"
- break
- fi
-done
-if test -z "$ac_aux_dir"; then
- { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; }
-fi
-ac_config_guess=$ac_aux_dir/config.guess
-ac_config_sub=$ac_aux_dir/config.sub
-ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
-
-# Find a good install program. We prefer a C program (faster),
-# so one script is as good as another. But avoid the broken or
-# incompatible versions:
-# SysV /etc/install, /usr/sbin/install
-# SunOS /usr/etc/install
-# IRIX /sbin/install
-# AIX /bin/install
-# AFS /usr/afsws/bin/install, which mishandles nonexistent args
-# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
-# ./install, which can be erroneously created by make from ./install.sh.
-echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6
-echo "configure:561: checking for a BSD compatible install" >&5
-if test -z "$INSTALL"; then
-if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:"
- for ac_dir in $PATH; do
- # Account for people who put trailing slashes in PATH elements.
- case "$ac_dir/" in
- /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;;
- *)
- # OSF1 and SCO ODT 3.0 have their own names for install.
- for ac_prog in ginstall installbsd scoinst install; do
- if test -f $ac_dir/$ac_prog; then
- if test $ac_prog = install &&
- grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then
- # AIX install. It has an incompatible calling convention.
- # OSF/1 installbsd also uses dspmsg, but is usable.
- :
- else
- ac_cv_path_install="$ac_dir/$ac_prog -c"
- break 2
- fi
- fi
- done
- ;;
- esac
- done
- IFS="$ac_save_IFS"
-
-fi
- if test "${ac_cv_path_install+set}" = set; then
- INSTALL="$ac_cv_path_install"
- else
- # As a last resort, use the slow shell script. We don't cache a
- # path for INSTALL within a source directory, because that will
- # break other packages using the cache if that directory is
- # removed, or if the path is relative.
- INSTALL="$ac_install_sh"
- fi
-fi
-echo "$ac_t""$INSTALL" 1>&6
-
-# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
-# It thinks the first close brace ends the variable substitution.
-test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
-
-test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
-
-
-test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
-
-
-. $srcdir/../GUILE-VERSION
-
-PACKAGE=$PACKAGE
-
-cat >> confdefs.h <<EOF
-#define PACKAGE "$PACKAGE"
-EOF
-
-VERSION=$VERSION
-
-cat >> confdefs.h <<EOF
-#define VERSION "$VERSION"
-EOF
-
-echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6
-echo "configure:629: checking whether build environment is sane" >&5
-echo timestamp > conftestfile
-# Do this in a subshell so we don't clobber the current shell's
-# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test?
-if (set X `ls -t $srcdir/configure conftestfile`; test "$2" = conftestfile)
-then
- # Ok.
- :
-else
- { echo "configure: error: newly created file is older than distributed files!
-Check your system clock" 1>&2; exit 1; }
-fi
-rm -f conftest*
-echo "$ac_t""yes" 1>&6
-if test "$program_transform_name" = s,x,x,; then
- program_transform_name=
-else
- # Double any \ or $. echo might interpret backslashes.
- cat <<\EOF_SED > conftestsed
-s,\\,\\\\,g; s,\$,$$,g
-EOF_SED
- program_transform_name="`echo $program_transform_name|sed -f conftestsed`"
- rm -f conftestsed
-fi
-test "$program_prefix" != NONE &&
- program_transform_name="s,^,${program_prefix},; $program_transform_name"
-# Use a double $ so make ignores it.
-test "$program_suffix" != NONE &&
- program_transform_name="s,\$\$,${program_suffix},; $program_transform_name"
-
-# sed with no file args requires a program.
-test "$program_transform_name" = "" && program_transform_name="s,x,x,"
-
-echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
-echo "configure:663: checking whether ${MAKE-make} sets \${MAKE}" >&5
-set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
-if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftestmake <<\EOF
-all:
- @echo 'ac_maketemp="${MAKE}"'
-EOF
-# GNU make sometimes prints "make[1]: Entering...", which would confuse us.
-eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=`
-if test -n "$ac_maketemp"; then
- eval ac_cv_prog_make_${ac_make}_set=yes
-else
- eval ac_cv_prog_make_${ac_make}_set=no
-fi
-rm -f conftestmake
-fi
-if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- SET_MAKE=
-else
- echo "$ac_t""no" 1>&6
- SET_MAKE="MAKE=${MAKE-make}"
-fi
-
-ac_aux_dir=
-for ac_dir in .. $srcdir/..; do
- if test -f $ac_dir/install-sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install-sh -c"
- break
- elif test -f $ac_dir/install.sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install.sh -c"
- break
- fi
-done
-if test -z "$ac_aux_dir"; then
- { echo "configure: error: can not find install-sh or install.sh in .. $srcdir/.." 1>&2; exit 1; }
-fi
-ac_config_guess=$ac_aux_dir/config.guess
-ac_config_sub=$ac_aux_dir/config.sub
-ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
-
-module=libguile
-
-
-#--------------------------------------------------------------------
-#
-# User options
-#
-#--------------------------------------------------------------------
-
-# Check whether --enable-debug or --disable-debug was given.
-if test "${enable_debug+set}" = set; then
- enableval="$enable_debug"
- :
-fi
-
-if test "$enableval" != n && test "$enableval" != no; then
- cat >> confdefs.h <<\EOF
-#define DEBUG_EXTENSIONS 1
-EOF
-
- cat >> confdefs.h <<\EOF
-#define READER_EXTENSIONS 1
-EOF
-
- LIBOBJS="backtrace.o stacks.o debug.o srcprop.o $LIBOBJS"
-fi
-
-# Check whether --enable-dynamic-linking or --disable-dynamic-linking was given.
-if test "${enable_dynamic_linking+set}" = set; then
- enableval="$enable_dynamic_linking"
- :
-fi
-
-if test "$enableval" != n && test "$enableval" != no && test "$enableval" != ""; then
- cat >> confdefs.h <<\EOF
-#define DYNAMIC_LINKING 1
-EOF
-
-fi
-
-#--------------------------------------------------------------------
-
-# Extract the first word of "gcc", so it can be a program name with args.
-set dummy gcc; ac_word=$2
-echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:753: checking for $ac_word" >&5
-if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- if test -n "$CC"; then
- ac_cv_prog_CC="$CC" # Let the user override the test.
-else
- IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:"
- for ac_dir in $PATH; do
- test -z "$ac_dir" && ac_dir=.
- if test -f $ac_dir/$ac_word; then
- ac_cv_prog_CC="gcc"
- break
- fi
- done
- IFS="$ac_save_ifs"
-fi
-fi
-CC="$ac_cv_prog_CC"
-if test -n "$CC"; then
- echo "$ac_t""$CC" 1>&6
-else
- echo "$ac_t""no" 1>&6
-fi
-
-if test -z "$CC"; then
- # Extract the first word of "cc", so it can be a program name with args.
-set dummy cc; ac_word=$2
-echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:782: checking for $ac_word" >&5
-if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- if test -n "$CC"; then
- ac_cv_prog_CC="$CC" # Let the user override the test.
-else
- IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:"
- ac_prog_rejected=no
- for ac_dir in $PATH; do
- test -z "$ac_dir" && ac_dir=.
- if test -f $ac_dir/$ac_word; then
- if test "$ac_dir/$ac_word" = "/usr/ucb/cc"; then
- ac_prog_rejected=yes
- continue
- fi
- ac_cv_prog_CC="cc"
- break
- fi
- done
- IFS="$ac_save_ifs"
-if test $ac_prog_rejected = yes; then
- # We found a bogon in the path, so make sure we never use it.
- set dummy $ac_cv_prog_CC
- shift
- if test $# -gt 0; then
- # We chose a different compiler from the bogus one.
- # However, it has the same basename, so the bogon will be chosen
- # first if we set CC to just the basename; use the full file name.
- shift
- set dummy "$ac_dir/$ac_word" "$@"
- shift
- ac_cv_prog_CC="$@"
- fi
-fi
-fi
-fi
-CC="$ac_cv_prog_CC"
-if test -n "$CC"; then
- echo "$ac_t""$CC" 1>&6
-else
- echo "$ac_t""no" 1>&6
-fi
-
- test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; }
-fi
-
-echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
-echo "configure:830: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
-
-ac_ext=c
-# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
-ac_cpp='$CPP $CPPFLAGS'
-ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
-ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
-cross_compiling=$ac_cv_prog_cc_cross
-
-cat > conftest.$ac_ext <<EOF
-#line 840 "configure"
-#include "confdefs.h"
-main(){return(0);}
-EOF
-if { (eval echo configure:844: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
- ac_cv_prog_cc_works=yes
- # If we can't run a trivial program, we are probably using a cross compiler.
- if (./conftest; exit) 2>/dev/null; then
- ac_cv_prog_cc_cross=no
- else
- ac_cv_prog_cc_cross=yes
- fi
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- ac_cv_prog_cc_works=no
-fi
-rm -fr conftest*
-
-echo "$ac_t""$ac_cv_prog_cc_works" 1>&6
-if test $ac_cv_prog_cc_works = no; then
- { echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
-fi
-echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
-echo "configure:864: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
-echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
-cross_compiling=$ac_cv_prog_cc_cross
-
-echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
-echo "configure:869: checking whether we are using GNU C" >&5
-if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.c <<EOF
-#ifdef __GNUC__
- yes;
-#endif
-EOF
-if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:878: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
- ac_cv_prog_gcc=yes
-else
- ac_cv_prog_gcc=no
-fi
-fi
-
-echo "$ac_t""$ac_cv_prog_gcc" 1>&6
-
-if test $ac_cv_prog_gcc = yes; then
- GCC=yes
- ac_test_CFLAGS="${CFLAGS+set}"
- ac_save_CFLAGS="$CFLAGS"
- CFLAGS=
- echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
-echo "configure:893: checking whether ${CC-cc} accepts -g" >&5
-if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- echo 'void f(){}' > conftest.c
-if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
- ac_cv_prog_cc_g=yes
-else
- ac_cv_prog_cc_g=no
-fi
-rm -f conftest*
-
-fi
-
-echo "$ac_t""$ac_cv_prog_cc_g" 1>&6
- if test "$ac_test_CFLAGS" = set; then
- CFLAGS="$ac_save_CFLAGS"
- elif test $ac_cv_prog_cc_g = yes; then
- CFLAGS="-g -O2"
- else
- CFLAGS="-O2"
- fi
-else
- GCC=
- test "${CFLAGS+set}" = set || CFLAGS="-g"
-fi
-
-echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
-echo "configure:921: checking how to run the C preprocessor" >&5
-# On Suns, sometimes $CPP names a directory.
-if test -n "$CPP" && test -d "$CPP"; then
- CPP=
-fi
-if test -z "$CPP"; then
-if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- # This must be in double quotes, not single quotes, because CPP may get
- # substituted into the Makefile and "${CC-cc}" will confuse make.
- CPP="${CC-cc} -E"
- # On the NeXT, cc -E runs the code through the compiler's parser,
- # not just through cpp.
- cat > conftest.$ac_ext <<EOF
-#line 936 "configure"
-#include "confdefs.h"
-#include <assert.h>
-Syntax Error
-EOF
-ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:942: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
-ac_err=`grep -v '^ *+' conftest.out`
-if test -z "$ac_err"; then
- :
-else
- echo "$ac_err" >&5
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- CPP="${CC-cc} -E -traditional-cpp"
- cat > conftest.$ac_ext <<EOF
-#line 953 "configure"
-#include "confdefs.h"
-#include <assert.h>
-Syntax Error
-EOF
-ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:959: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
-ac_err=`grep -v '^ *+' conftest.out`
-if test -z "$ac_err"; then
- :
-else
- echo "$ac_err" >&5
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- CPP=/lib/cpp
-fi
-rm -f conftest*
-fi
-rm -f conftest*
- ac_cv_prog_CPP="$CPP"
-fi
- CPP="$ac_cv_prog_CPP"
-else
- ac_cv_prog_CPP="$CPP"
-fi
-echo "$ac_t""$CPP" 1>&6
-
-# Extract the first word of "ranlib", so it can be a program name with args.
-set dummy ranlib; ac_word=$2
-echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:984: checking for $ac_word" >&5
-if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- if test -n "$RANLIB"; then
- ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
-else
- IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:"
- for ac_dir in $PATH; do
- test -z "$ac_dir" && ac_dir=.
- if test -f $ac_dir/$ac_word; then
- ac_cv_prog_RANLIB="ranlib"
- break
- fi
- done
- IFS="$ac_save_ifs"
- test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":"
-fi
-fi
-RANLIB="$ac_cv_prog_RANLIB"
-if test -n "$RANLIB"; then
- echo "$ac_t""$RANLIB" 1>&6
-else
- echo "$ac_t""no" 1>&6
-fi
-
-
-echo $ac_n "checking for AIX""... $ac_c" 1>&6
-echo "configure:1012: checking for AIX" >&5
-cat > conftest.$ac_ext <<EOF
-#line 1014 "configure"
-#include "confdefs.h"
-#ifdef _AIX
- yes
-#endif
-
-EOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- egrep "yes" >/dev/null 2>&1; then
- rm -rf conftest*
- echo "$ac_t""yes" 1>&6; cat >> confdefs.h <<\EOF
-#define _ALL_SOURCE 1
-EOF
-
-else
- rm -rf conftest*
- echo "$ac_t""no" 1>&6
-fi
-rm -f conftest*
-
-
-echo $ac_n "checking for POSIXized ISC""... $ac_c" 1>&6
-echo "configure:1036: checking for POSIXized ISC" >&5
-if test -d /etc/conf/kconfig.d &&
- grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1
-then
- echo "$ac_t""yes" 1>&6
- ISC=yes # If later tests want to check for ISC.
- cat >> confdefs.h <<\EOF
-#define _POSIX_SOURCE 1
-EOF
-
- if test "$GCC" = yes; then
- CC="$CC -posix"
- else
- CC="$CC -Xp"
- fi
-else
- echo "$ac_t""no" 1>&6
- ISC=
-fi
-
-ac_safe=`echo "minix/config.h" | sed 'y%./+-%__p_%'`
-echo $ac_n "checking for minix/config.h""... $ac_c" 1>&6
-echo "configure:1058: checking for minix/config.h" >&5
-if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1063 "configure"
-#include "confdefs.h"
-#include <minix/config.h>
-EOF
-ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1068: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
-ac_err=`grep -v '^ *+' conftest.out`
-if test -z "$ac_err"; then
- rm -rf conftest*
- eval "ac_cv_header_$ac_safe=yes"
-else
- echo "$ac_err" >&5
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_header_$ac_safe=no"
-fi
-rm -f conftest*
-fi
-if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- MINIX=yes
-else
- echo "$ac_t""no" 1>&6
-MINIX=
-fi
-
-if test "$MINIX" = yes; then
- cat >> confdefs.h <<\EOF
-#define _POSIX_SOURCE 1
-EOF
-
- cat >> confdefs.h <<\EOF
-#define _POSIX_1_SOURCE 2
-EOF
-
- cat >> confdefs.h <<\EOF
-#define _MINIX 1
-EOF
-
-fi
-
-
-
-echo $ac_n "checking "threads package type"""... $ac_c" 1>&6
-echo "configure:1108: checking "threads package type"" >&5
-if eval "test \"`echo '$''{'cy_cv_threads_package'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
-
-if eval "test \"`echo '$''{'cy_cv_threads_cflags'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
-
-if eval "test \"`echo '$''{'cy_cv_threads_libs'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
-
-use_threads=no;
-# Check whether --with-threads or --without-threads was given.
-if test "${with_threads+set}" = set; then
- withval="$with_threads"
- use_threads=$withval
-else
- use_threads=no
-fi
-
-test -n "$use_threads" || use_threads=qt
-threads_package=unknown
-if test "$use_threads" != no; then
- if test "$use_threads" = yes || test "$use_threads" = qt; then
- # Look for qt in source directory. This is a hack: we look in
- # "./qt" because this check might be run at the top level.
- if test -f $srcdir/../qt/qt.c || test -f $srcdir/qt/qt.c; then
- threads_package=COOP
- cy_cv_threads_cflags="-I$srcdir/../qt -I../qt"
- cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a"
- fi
- else
- if test -f $use_threads/qt.c; then
- # FIXME seems as though we should try to use an installed qt here.
- threads_package=COOP
- cy_cv_threads_cflags="-I$use_threads -I../qt"
- cy_cv_threads_libs="../threads/libthreads.a ../qt/libqt.a"
- fi
- fi
- if test "$use_threads" = pthreads; then
- # Look for pthreads in srcdir. See above to understand why
- # we always set threads_package.
- if test -f $srcdir/../../pthreads/pthreads/queue.c \
- || test -f $srcdir/../pthreads/pthreads/queue.c; then
- threads_package=MIT
- cy_cv_threads_cflags="-I$srcdir/../../pthreads/include"
- cy_cv_threads_libs="-L../../pthreads/lib -lpthread"
- fi
- fi
- saved_CPP="$CPPFLAGS"
- saved_LD="$LDFLAGS"
- saved_LIBS="$LIBS"
- if test "$threads_package" = unknown; then
- CPPFLAGS="-I$use_threads/include"
- LDFLAGS="-L$use_threads/lib"
- LIBS="-lgthreads -lmalloc"
- cat > conftest.$ac_ext <<EOF
-#line 1167 "configure"
-#include "confdefs.h"
-#include <pthread.h>
-int main() {
-
-pthread_equal(NULL,NULL);
-
-; return 0; }
-EOF
-if { (eval echo configure:1176: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
- rm -rf conftest*
- threads_package=FSU
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
-fi
-rm -f conftest*
- fi
- if test "$threads_package" = unknown; then
- LIBS="-lpthread"
- cat > conftest.$ac_ext <<EOF
-#line 1188 "configure"
-#include "confdefs.h"
-#include <pthread.h>
-int main() {
-
-pthread_equal(NULL,NULL);
-
-; return 0; }
-EOF
-if { (eval echo configure:1197: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
- rm -rf conftest*
- threads_package=MIT
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
-fi
-rm -f conftest*
- fi
- if test "$threads_package" = unknown; then
- LIBS="-lpthreads"
- cat > conftest.$ac_ext <<EOF
-#line 1209 "configure"
-#include "confdefs.h"
-#include <pthread.h>
-int main() {
-
-pthread_equal(NULL,NULL);
-
-; return 0; }
-EOF
-if { (eval echo configure:1218: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
- rm -rf conftest*
- threads_package=PCthreads
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
-fi
-rm -f conftest*
- fi
- cy_cv_threads_cflags="$CPPFLAGS $cy_cv_threads_cflags"
- cy_cv_threads_libs="$LDFLAGS $LIBS $cy_cv_threads_libs"
- cy_cv_threads_package=$threads_package
- CPPFLAGS="$saved_CPP"
- LDFLAGS="$saved_LD"
- LIBS="$saved_LIBS"
- if test "$threads_package" = unknown; then
- { echo "configure: error: "cannot find thread library installation"" 1>&2; exit 1; }
- fi
-fi
-
-fi
-
-
-fi
-
-
-fi
-
-echo "$ac_t""$cy_cv_threads_package" 1>&6
-
-
-echo $ac_n "checking for working const""... $ac_c" 1>&6
-echo "configure:1250: checking for working const" >&5
-if eval "test \"`echo '$''{'ac_cv_c_const'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1255 "configure"
-#include "confdefs.h"
-
-int main() {
-
-/* Ultrix mips cc rejects this. */
-typedef int charset[2]; const charset x;
-/* SunOS 4.1.1 cc rejects this. */
-char const *const *ccp;
-char **p;
-/* NEC SVR4.0.2 mips cc rejects this. */
-struct point {int x, y;};
-static struct point const zero = {0,0};
-/* AIX XL C 1.02.0.0 rejects this.
- It does not let you subtract one const X* pointer from another in an arm
- of an if-expression whose if-part is not a constant expression */
-const char *g = "string";
-ccp = &g + (g ? g-g : 0);
-/* HPUX 7.0 cc rejects these. */
-++ccp;
-p = (char**) ccp;
-ccp = (char const *const *) p;
-{ /* SCO 3.2v4 cc rejects this. */
- char *t;
- char const *s = 0 ? (char *) 0 : (char const *) 0;
-
- *t++ = 0;
-}
-{ /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */
- int x[] = {25, 17};
- const int *foo = &x[0];
- ++foo;
-}
-{ /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */
- typedef const int *iptr;
- iptr p = 0;
- ++p;
-}
-{ /* AIX XL C 1.02.0.0 rejects this saying
- "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */
- struct s { int j; const int *ap[3]; };
- struct s *b; b->j = 5;
-}
-{ /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */
- const int foo = 10;
-}
-
-; return 0; }
-EOF
-if { (eval echo configure:1304: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_c_const=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_c_const=no
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_c_const" 1>&6
-if test $ac_cv_c_const = no; then
- cat >> confdefs.h <<\EOF
-#define const
-EOF
-
-fi
-
-
-echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6
-echo "configure:1326: checking for ANSI C header files" >&5
-if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1331 "configure"
-#include "confdefs.h"
-#include <stdlib.h>
-#include <stdarg.h>
-#include <string.h>
-#include <float.h>
-EOF
-ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1339: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
-ac_err=`grep -v '^ *+' conftest.out`
-if test -z "$ac_err"; then
- rm -rf conftest*
- ac_cv_header_stdc=yes
-else
- echo "$ac_err" >&5
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_header_stdc=no
-fi
-rm -f conftest*
-
-if test $ac_cv_header_stdc = yes; then
- # SunOS 4.x string.h does not declare mem*, contrary to ANSI.
-cat > conftest.$ac_ext <<EOF
-#line 1356 "configure"
-#include "confdefs.h"
-#include <string.h>
-EOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- egrep "memchr" >/dev/null 2>&1; then
- :
-else
- rm -rf conftest*
- ac_cv_header_stdc=no
-fi
-rm -f conftest*
-
-fi
-
-if test $ac_cv_header_stdc = yes; then
- # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
-cat > conftest.$ac_ext <<EOF
-#line 1374 "configure"
-#include "confdefs.h"
-#include <stdlib.h>
-EOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- egrep "free" >/dev/null 2>&1; then
- :
-else
- rm -rf conftest*
- ac_cv_header_stdc=no
-fi
-rm -f conftest*
-
-fi
-
-if test $ac_cv_header_stdc = yes; then
- # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
-if test "$cross_compiling" = yes; then
- :
-else
- cat > conftest.$ac_ext <<EOF
-#line 1395 "configure"
-#include "confdefs.h"
-#include <ctype.h>
-#define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
-#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
-#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
-int main () { int i; for (i = 0; i < 256; i++)
-if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2);
-exit (0); }
-
-EOF
-if { (eval echo configure:1406: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null
-then
- :
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -fr conftest*
- ac_cv_header_stdc=no
-fi
-rm -fr conftest*
-fi
-
-fi
-fi
-
-echo "$ac_t""$ac_cv_header_stdc" 1>&6
-if test $ac_cv_header_stdc = yes; then
- cat >> confdefs.h <<\EOF
-#define STDC_HEADERS 1
-EOF
-
-fi
-
-ac_header_dirent=no
-for ac_hdr in dirent.h sys/ndir.h sys/dir.h ndir.h
-do
-ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
-echo $ac_n "checking for $ac_hdr that defines DIR""... $ac_c" 1>&6
-echo "configure:1434: checking for $ac_hdr that defines DIR" >&5
-if eval "test \"`echo '$''{'ac_cv_header_dirent_$ac_safe'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1439 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <$ac_hdr>
-int main() {
-DIR *dirp = 0;
-; return 0; }
-EOF
-if { (eval echo configure:1447: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- eval "ac_cv_header_dirent_$ac_safe=yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_header_dirent_$ac_safe=no"
-fi
-rm -f conftest*
-fi
-if eval "test \"`echo '$ac_cv_header_dirent_'$ac_safe`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'`
- cat >> confdefs.h <<EOF
-#define $ac_tr_hdr 1
-EOF
- ac_header_dirent=$ac_hdr; break
-else
- echo "$ac_t""no" 1>&6
-fi
-done
-# Two versions of opendir et al. are in -ldir and -lx on SCO Xenix.
-if test $ac_header_dirent = dirent.h; then
-echo $ac_n "checking for opendir in -ldir""... $ac_c" 1>&6
-echo "configure:1472: checking for opendir in -ldir" >&5
-ac_lib_var=`echo dir'_'opendir | sed 'y%./+-%__p_%'`
-if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- ac_save_LIBS="$LIBS"
-LIBS="-ldir $LIBS"
-cat > conftest.$ac_ext <<EOF
-#line 1480 "configure"
-#include "confdefs.h"
-/* Override any gcc2 internal prototype to avoid an error. */
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char opendir();
-
-int main() {
-opendir()
-; return 0; }
-EOF
-if { (eval echo configure:1491: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=no"
-fi
-rm -f conftest*
-LIBS="$ac_save_LIBS"
-
-fi
-if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- LIBS="$LIBS -ldir"
-else
- echo "$ac_t""no" 1>&6
-fi
-
-else
-echo $ac_n "checking for opendir in -lx""... $ac_c" 1>&6
-echo "configure:1513: checking for opendir in -lx" >&5
-ac_lib_var=`echo x'_'opendir | sed 'y%./+-%__p_%'`
-if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- ac_save_LIBS="$LIBS"
-LIBS="-lx $LIBS"
-cat > conftest.$ac_ext <<EOF
-#line 1521 "configure"
-#include "confdefs.h"
-/* Override any gcc2 internal prototype to avoid an error. */
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char opendir();
-
-int main() {
-opendir()
-; return 0; }
-EOF
-if { (eval echo configure:1532: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=no"
-fi
-rm -f conftest*
-LIBS="$ac_save_LIBS"
-
-fi
-if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- LIBS="$LIBS -lx"
-else
- echo "$ac_t""no" 1>&6
-fi
-
-fi
-
-echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6
-echo "configure:1555: checking whether time.h and sys/time.h may both be included" >&5
-if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1560 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <sys/time.h>
-#include <time.h>
-int main() {
-struct tm *tp;
-; return 0; }
-EOF
-if { (eval echo configure:1569: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_header_time=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_header_time=no
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_header_time" 1>&6
-if test $ac_cv_header_time = yes; then
- cat >> confdefs.h <<\EOF
-#define TIME_WITH_SYS_TIME 1
-EOF
-
-fi
-
-echo $ac_n "checking for sys/wait.h that is POSIX.1 compatible""... $ac_c" 1>&6
-echo "configure:1590: checking for sys/wait.h that is POSIX.1 compatible" >&5
-if eval "test \"`echo '$''{'ac_cv_header_sys_wait_h'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1595 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <sys/wait.h>
-#ifndef WEXITSTATUS
-#define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
-#endif
-#ifndef WIFEXITED
-#define WIFEXITED(stat_val) (((stat_val) & 255) == 0)
-#endif
-int main() {
-int s;
-wait (&s);
-s = WIFEXITED (s) ? WEXITSTATUS (s) : 1;
-; return 0; }
-EOF
-if { (eval echo configure:1611: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_header_sys_wait_h=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_header_sys_wait_h=no
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_header_sys_wait_h" 1>&6
-if test $ac_cv_header_sys_wait_h = yes; then
- cat >> confdefs.h <<\EOF
-#define HAVE_SYS_WAIT_H 1
-EOF
-
-fi
-
-for ac_hdr in libc.h limits.h malloc.h memory.h string.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/types.h sys/utime.h time.h unistd.h utime.h
-do
-ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
-echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:1635: checking for $ac_hdr" >&5
-if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1640 "configure"
-#include "confdefs.h"
-#include <$ac_hdr>
-EOF
-ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1645: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
-ac_err=`grep -v '^ *+' conftest.out`
-if test -z "$ac_err"; then
- rm -rf conftest*
- eval "ac_cv_header_$ac_safe=yes"
-else
- echo "$ac_err" >&5
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_header_$ac_safe=no"
-fi
-rm -f conftest*
-fi
-if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'`
- cat >> confdefs.h <<EOF
-#define $ac_tr_hdr 1
-EOF
-
-else
- echo "$ac_t""no" 1>&6
-fi
-done
-
-
- for ac_hdr in libc.h unistd.h
-do
-ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
-echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:1676: checking for $ac_hdr" >&5
-if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1681 "configure"
-#include "confdefs.h"
-#include <$ac_hdr>
-EOF
-ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1686: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
-ac_err=`grep -v '^ *+' conftest.out`
-if test -z "$ac_err"; then
- rm -rf conftest*
- eval "ac_cv_header_$ac_safe=yes"
-else
- echo "$ac_err" >&5
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_header_$ac_safe=no"
-fi
-rm -f conftest*
-fi
-if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'`
- cat >> confdefs.h <<EOF
-#define $ac_tr_hdr 1
-EOF
-
-else
- echo "$ac_t""no" 1>&6
-fi
-done
-
- echo $ac_n "checking "whether libc.h and unistd.h can be included together"""... $ac_c" 1>&6
-echo "configure:1713: checking "whether libc.h and unistd.h can be included together"" >&5
-if eval "test \"`echo '$''{'guile_cv_header_libc_with_unistd'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
-
- if test "$ac_cv_header_libc_h" = "no"; then
- guile_cv_header_libc_with_unistd="no"
- elif test "$ac_cv_header_unistd.h" = "no"; then
- guile_cv_header_libc_with_unistd="yes"
- else
- cat > conftest.$ac_ext <<EOF
-#line 1724 "configure"
-#include "confdefs.h"
-
-# include <libc.h>
-# include <unistd.h>
-
-int main() {
-
-; return 0; }
-EOF
-if { (eval echo configure:1734: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- guile_cv_header_libc_with_unistd=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- guile_cv_header_libc_with_unistd=no
-
-fi
-rm -f conftest*
- fi
-
-
-fi
-
-echo "$ac_t""$guile_cv_header_libc_with_unistd" 1>&6
- if test "$guile_cv_header_libc_with_unistd" = yes; then
- cat >> confdefs.h <<\EOF
-#define LIBC_H_WITH_UNISTD_H 1
-EOF
-
- fi
-
-
-
-echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6
-echo "configure:1761: checking for uid_t in sys/types.h" >&5
-if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1766 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-EOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- egrep "uid_t" >/dev/null 2>&1; then
- rm -rf conftest*
- ac_cv_type_uid_t=yes
-else
- rm -rf conftest*
- ac_cv_type_uid_t=no
-fi
-rm -f conftest*
-
-fi
-
-echo "$ac_t""$ac_cv_type_uid_t" 1>&6
-if test $ac_cv_type_uid_t = no; then
- cat >> confdefs.h <<\EOF
-#define uid_t int
-EOF
-
- cat >> confdefs.h <<\EOF
-#define gid_t int
-EOF
-
-fi
-
-echo $ac_n "checking type of array argument to getgroups""... $ac_c" 1>&6
-echo "configure:1795: checking type of array argument to getgroups" >&5
-if eval "test \"`echo '$''{'ac_cv_type_getgroups'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- if test "$cross_compiling" = yes; then
- ac_cv_type_getgroups=cross
-else
- cat > conftest.$ac_ext <<EOF
-#line 1803 "configure"
-#include "confdefs.h"
-
-/* Thanks to Mike Rendell for this test. */
-#include <sys/types.h>
-#define NGID 256
-#undef MAX
-#define MAX(x, y) ((x) > (y) ? (x) : (y))
-main()
-{
- gid_t gidset[NGID];
- int i, n;
- union { gid_t gval; long lval; } val;
-
- val.lval = -1;
- for (i = 0; i < NGID; i++)
- gidset[i] = val.gval;
- n = getgroups (sizeof (gidset) / MAX (sizeof (int), sizeof (gid_t)) - 1,
- gidset);
- /* Exit non-zero if getgroups seems to require an array of ints. This
- happens when gid_t is short but getgroups modifies an array of ints. */
- exit ((n > 0 && gidset[n] != val.gval) ? 1 : 0);
-}
-
-EOF
-if { (eval echo configure:1828: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null
-then
- ac_cv_type_getgroups=gid_t
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -fr conftest*
- ac_cv_type_getgroups=int
-fi
-rm -fr conftest*
-fi
-
-if test $ac_cv_type_getgroups = cross; then
- cat > conftest.$ac_ext <<EOF
-#line 1842 "configure"
-#include "confdefs.h"
-#include <unistd.h>
-EOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- egrep "getgroups.*int.*gid_t" >/dev/null 2>&1; then
- rm -rf conftest*
- ac_cv_type_getgroups=gid_t
-else
- rm -rf conftest*
- ac_cv_type_getgroups=int
-fi
-rm -f conftest*
-
-fi
-fi
-
-echo "$ac_t""$ac_cv_type_getgroups" 1>&6
-cat >> confdefs.h <<EOF
-#define GETGROUPS_T $ac_cv_type_getgroups
-EOF
-
-
-echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6
-echo "configure:1866: checking return type of signal handlers" >&5
-if eval "test \"`echo '$''{'ac_cv_type_signal'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1871 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <signal.h>
-#ifdef signal
-#undef signal
-#endif
-#ifdef __cplusplus
-extern "C" void (*signal (int, void (*)(int)))(int);
-#else
-void (*signal ()) ();
-#endif
-
-int main() {
-int i;
-; return 0; }
-EOF
-if { (eval echo configure:1888: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_type_signal=void
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_type_signal=int
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_type_signal" 1>&6
-cat >> confdefs.h <<EOF
-#define RETSIGTYPE $ac_cv_type_signal
-EOF
-
-
-echo $ac_n "checking for mode_t""... $ac_c" 1>&6
-echo "configure:1907: checking for mode_t" >&5
-if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1912 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#if STDC_HEADERS
-#include <stdlib.h>
-#include <stddef.h>
-#endif
-EOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- egrep "mode_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then
- rm -rf conftest*
- ac_cv_type_mode_t=yes
-else
- rm -rf conftest*
- ac_cv_type_mode_t=no
-fi
-rm -f conftest*
-
-fi
-echo "$ac_t""$ac_cv_type_mode_t" 1>&6
-if test $ac_cv_type_mode_t = no; then
- cat >> confdefs.h <<\EOF
-#define mode_t int
-EOF
-
-fi
-
-
-for ac_func in ctermid ftime getcwd geteuid lstat mkdir mknod nice putenv readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid
-do
-echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:1943: checking for $ac_func" >&5
-if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1948 "configure"
-#include "confdefs.h"
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func(); below. */
-#include <assert.h>
-/* Override any gcc2 internal prototype to avoid an error. */
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func();
-
-int main() {
-
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-$ac_func();
-#endif
-
-; return 0; }
-EOF
-if { (eval echo configure:1971: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
- rm -rf conftest*
- eval "ac_cv_func_$ac_func=yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_func_$ac_func=no"
-fi
-rm -f conftest*
-fi
-
-if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
- cat >> confdefs.h <<EOF
-#define $ac_tr_func 1
-EOF
-
-else
- echo "$ac_t""no" 1>&6
-fi
-done
-
-
-for ac_func in inet_aton strerror
-do
-echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:1999: checking for $ac_func" >&5
-if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 2004 "configure"
-#include "confdefs.h"
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func(); below. */
-#include <assert.h>
-/* Override any gcc2 internal prototype to avoid an error. */
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func();
-
-int main() {
-
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-$ac_func();
-#endif
-
-; return 0; }
-EOF
-if { (eval echo configure:2027: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
- rm -rf conftest*
- eval "ac_cv_func_$ac_func=yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_func_$ac_func=no"
-fi
-rm -f conftest*
-fi
-
-if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
- cat >> confdefs.h <<EOF
-#define $ac_tr_func 1
-EOF
-
-else
- echo "$ac_t""no" 1>&6
-LIBOBJS="$LIBOBJS ${ac_func}.o"
-fi
-done
-
-
-
-echo $ac_n "checking for st_rdev in struct stat""... $ac_c" 1>&6
-echo "configure:2055: checking for st_rdev in struct stat" >&5
-if eval "test \"`echo '$''{'ac_cv_struct_st_rdev'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 2060 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <sys/stat.h>
-int main() {
-struct stat s; s.st_rdev;
-; return 0; }
-EOF
-if { (eval echo configure:2068: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_struct_st_rdev=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_struct_st_rdev=no
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_struct_st_rdev" 1>&6
-if test $ac_cv_struct_st_rdev = yes; then
- cat >> confdefs.h <<\EOF
-#define HAVE_ST_RDEV 1
-EOF
-
-fi
-
-echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6
-echo "configure:2089: checking for st_blksize in struct stat" >&5
-if eval "test \"`echo '$''{'ac_cv_struct_st_blksize'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 2094 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <sys/stat.h>
-int main() {
-struct stat s; s.st_blksize;
-; return 0; }
-EOF
-if { (eval echo configure:2102: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_struct_st_blksize=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_struct_st_blksize=no
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_struct_st_blksize" 1>&6
-if test $ac_cv_struct_st_blksize = yes; then
- cat >> confdefs.h <<\EOF
-#define HAVE_ST_BLKSIZE 1
-EOF
-
-fi
-
-echo $ac_n "checking for st_blocks in struct stat""... $ac_c" 1>&6
-echo "configure:2123: checking for st_blocks in struct stat" >&5
-if eval "test \"`echo '$''{'ac_cv_struct_st_blocks'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 2128 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <sys/stat.h>
-int main() {
-struct stat s; s.st_blocks;
-; return 0; }
-EOF
-if { (eval echo configure:2136: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_struct_st_blocks=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_struct_st_blocks=no
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_struct_st_blocks" 1>&6
-if test $ac_cv_struct_st_blocks = yes; then
- cat >> confdefs.h <<\EOF
-#define HAVE_ST_BLOCKS 1
-EOF
-
-else
- LIBOBJS="$LIBOBJS fileblocks.o"
-fi
-
-
- echo $ac_n "checking whether we need POSIX to get struct utimbuf""... $ac_c" 1>&6
-echo "configure:2160: checking whether we need POSIX to get struct utimbuf" >&5
-if eval "test \"`echo '$''{'guile_cv_struct_utimbuf_needs_posix'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 2165 "configure"
-#include "confdefs.h"
-
-#ifdef __EMX__
-#include <sys/utime.h>
-#else
-#include <utime.h>
-#endif
-struct utime blah;
-
-EOF
-ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2177: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
-ac_err=`grep -v '^ *+' conftest.out`
-if test -z "$ac_err"; then
- rm -rf conftest*
- guile_cv_struct_utimbuf_needs_posix=no
-else
- echo "$ac_err" >&5
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- guile_cv_struct_utimbuf_needs_posix=yes
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$guile_cv_struct_utimbuf_needs_posix" 1>&6
- if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then
- cat >> confdefs.h <<\EOF
-#define UTIMBUF_NEEDS_POSIX 1
-EOF
-
- fi
-
-# Checks for dynamic linking
-echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6
-echo "configure:2202: checking for dlopen in -ldl" >&5
-ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'`
-if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- ac_save_LIBS="$LIBS"
-LIBS="-ldl $LIBS"
-cat > conftest.$ac_ext <<EOF
-#line 2210 "configure"
-#include "confdefs.h"
-/* Override any gcc2 internal prototype to avoid an error. */
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char dlopen();
-
-int main() {
-dlopen()
-; return 0; }
-EOF
-if { (eval echo configure:2221: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=no"
-fi
-rm -f conftest*
-LIBS="$ac_save_LIBS"
-
-fi
-if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- ac_tr_lib=HAVE_LIB`echo dl | sed -e 's/[^a-zA-Z0-9_]/_/g' \
- -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'`
- cat >> confdefs.h <<EOF
-#define $ac_tr_lib 1
-EOF
-
- LIBS="-ldl $LIBS"
-
-else
- echo "$ac_t""no" 1>&6
-fi
-
-echo $ac_n "checking for dld_link in -ldld""... $ac_c" 1>&6
-echo "configure:2249: checking for dld_link in -ldld" >&5
-ac_lib_var=`echo dld'_'dld_link | sed 'y%./+-%__p_%'`
-if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- ac_save_LIBS="$LIBS"
-LIBS="-ldld $LIBS"
-cat > conftest.$ac_ext <<EOF
-#line 2257 "configure"
-#include "confdefs.h"
-/* Override any gcc2 internal prototype to avoid an error. */
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char dld_link();
-
-int main() {
-dld_link()
-; return 0; }
-EOF
-if { (eval echo configure:2268: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=no"
-fi
-rm -f conftest*
-LIBS="$ac_save_LIBS"
-
-fi
-if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- ac_tr_lib=HAVE_LIB`echo dld | sed -e 's/[^a-zA-Z0-9_]/_/g' \
- -e 'y/abcdefghijklmnopqrstuvwxyz/ABCDEFGHIJKLMNOPQRSTUVWXYZ/'`
- cat >> confdefs.h <<EOF
-#define $ac_tr_lib 1
-EOF
-
- LIBS="-ldld $LIBS"
-
-else
- echo "$ac_t""no" 1>&6
-fi
-
-for ac_func in shl_load
-do
-echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:2298: checking for $ac_func" >&5
-if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 2303 "configure"
-#include "confdefs.h"
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func(); below. */
-#include <assert.h>
-/* Override any gcc2 internal prototype to avoid an error. */
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char $ac_func();
-
-int main() {
-
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-$ac_func();
-#endif
-
-; return 0; }
-EOF
-if { (eval echo configure:2326: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
- rm -rf conftest*
- eval "ac_cv_func_$ac_func=yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_func_$ac_func=no"
-fi
-rm -f conftest*
-fi
-
-if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
- cat >> confdefs.h <<EOF
-#define $ac_tr_func 1
-EOF
-
-else
- echo "$ac_t""no" 1>&6
-fi
-done
-
-
-#--------------------------------------------------------------------
-#
-# Which way does the stack grow?
-#
-#--------------------------------------------------------------------
-
-if test "$cross_compiling" = yes; then
- echo "configure: warning: Guessing that stack grows down -- see scmconfig.h.in" 1>&2
-else
- cat > conftest.$ac_ext <<EOF
-#line 2361 "configure"
-#include "confdefs.h"
-aux (l) unsigned long l;
- { int x; exit (l >= ((unsigned long)&x)); }
- main () { int q; aux((unsigned long)&q); }
-EOF
-if { (eval echo configure:2367: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null
-then
- cat >> confdefs.h <<\EOF
-#define SCM_STACK_GROWS_UP 1
-EOF
-
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
-fi
-rm -fr conftest*
-fi
-
-
-
-if test "$cross_compiling" = yes; then
- cat >> confdefs.h <<\EOF
-#define SCM_SINGLES 1
-EOF
-
- echo "configure: warning: Guessing that sizeof(long) == sizeof(float) -- see scmconfig.h.in" 1>&2
-else
- cat > conftest.$ac_ext <<EOF
-#line 2390 "configure"
-#include "confdefs.h"
-main () { exit (sizeof(float) != sizeof(long)); }
-EOF
-if { (eval echo configure:2394: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null
-then
- cat >> confdefs.h <<\EOF
-#define SCM_SINGLES 1
-EOF
-
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
-fi
-rm -fr conftest*
-fi
-
-
-echo $ac_n "checking for struct linger""... $ac_c" 1>&6
-echo "configure:2409: checking for struct linger" >&5
-if eval "test \"`echo '$''{'scm_cv_struct_linger'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 2414 "configure"
-#include "confdefs.h"
-#include <sys/socket.h>
-int main() {
-struct linger lgr; lgr.l_linger = 100
-; return 0; }
-EOF
-if { (eval echo configure:2421: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- scm_cv_struct_linger="yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- scm_cv_struct_linger="no"
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$scm_cv_struct_linger" 1>&6
-if test $scm_cv_struct_linger = yes; then
- cat >> confdefs.h <<\EOF
-#define HAVE_STRUCT_LINGER 1
-EOF
-
-fi
-
-#--------------------------------------------------------------------
-#
-# How can you violate a stdio abstraction by setting a stream's fd?
-#
-#--------------------------------------------------------------------
-
-FD_SETTER=""
-
-if test "x$FD_SETTER" = x; then
- cat > conftest.$ac_ext <<EOF
-#line 2451 "configure"
-#include "confdefs.h"
-#include <stdio.h>
-
-int main() {
-stdout->_file = 1
-; return 0; }
-EOF
-if { (eval echo configure:2459: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- FD_SETTER="((F)->_file = (D))"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
-fi
-rm -f conftest*
-fi
-
-if test "x$FD_SETTER" = x; then
- cat > conftest.$ac_ext <<EOF
-#line 2471 "configure"
-#include "confdefs.h"
-#include <stdio.h>
-
-int main() {
-stdout->_fileno
-; return 0; }
-EOF
-if { (eval echo configure:2479: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- FD_SETTER="((F)->_fileno = (D))"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
-fi
-rm -f conftest*
-fi
-
-
-test "x$FD_SETTER" != x && cat >> confdefs.h <<\EOF
-#define HAVE_FD_SETTER 1
-EOF
-
-
-#--------------------------------------------------------------------
-# How to find out whether a FILE structure contains buffered data.
-# From Tk we have the following list:
-# _cnt: Most UNIX systems
-# __cnt: HPUX
-# _r: BSD
-# readCount: Sprite
-# Or, in GNU libc there are two fields, _gptr and _egptr, which
-# have to be compared.
-# These can also be known as _IO_read_ptr and _IO_read_end.
-#--------------------------------------------------------------------
-
-echo $ac_n "checking how to get buffer char count from FILE structure""... $ac_c" 1>&6
-echo "configure:2508: checking how to get buffer char count from FILE structure" >&5
-if eval "test \"`echo '$''{'scm_cv_struct_file_count'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 2513 "configure"
-#include "confdefs.h"
-#include <stdio.h>
-int main() {
-FILE *f = stdin; f->_cnt = 0
-; return 0; }
-EOF
-if { (eval echo configure:2520: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- scm_cv_struct_file_count="_cnt"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- cat > conftest.$ac_ext <<EOF
-#line 2528 "configure"
-#include "confdefs.h"
-#include <stdio.h>
-int main() {
-FILE *f = stdin; f->_r = 0
-; return 0; }
-EOF
-if { (eval echo configure:2535: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- scm_cv_struct_file_count="_r"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- cat > conftest.$ac_ext <<EOF
-#line 2543 "configure"
-#include "confdefs.h"
-#include <stdio.h>
-int main() {
-FILE *f = stdin; f->readCount = 0
-; return 0; }
-EOF
-if { (eval echo configure:2550: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- scm_cv_struct_file_count="readCount"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- scm_cv_struct_file_count=""
-fi
-rm -f conftest*
-fi
-rm -f conftest*
-fi
-rm -f conftest*
-fi
-
-if test "$scm_cv_struct_file_count"; then
- echo "$ac_t""$scm_cv_struct_file_count" 1>&6
- cat >> confdefs.h <<EOF
-#define FILE_CNT_FIELD $scm_cv_struct_file_count
-EOF
-
-else
-if eval "test \"`echo '$''{'scm_cv_struct_file_gptr'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 2577 "configure"
-#include "confdefs.h"
-#include <stdio.h>
-int main() {
-FILE *f = stdin; f->_gptr = f->egptr;
-; return 0; }
-EOF
-if { (eval echo configure:2584: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- scm_cv_struct_file_gptr=1
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- scm_cv_struct_file_gptr=""
-fi
-rm -f conftest*
-fi
-
-if test "$scm_cv_struct_gptr"; then
- echo "$ac_t""gptr" 1>&6
- cat >> confdefs.h <<EOF
-#define FILE_CNT_GPTR $scm_cv_struct_file_gptr
-EOF
-
-else
-if eval "test \"`echo '$''{'scm_cv_struct_file_readptr'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 2607 "configure"
-#include "confdefs.h"
-#include <stdio.h>
-int main() {
-FILE *f = stdin; f->_IO_read_ptr = f->_IO_read_end;
-; return 0; }
-EOF
-if { (eval echo configure:2614: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- scm_cv_struct_file_readptr=1
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
-fi
-rm -f conftest*
-fi
-
-if test "$scm_cv_struct_file_readptr"; then
- echo "$ac_t""read_ptr" 1>&6
- cat >> confdefs.h <<EOF
-#define FILE_CNT_READPTR $scm_cv_struct_file_readptr
-EOF
-
-fi
-fi
-fi
-
-#--------------------------------------------------------------------
-#
-# Flags for thread support
-#
-#--------------------------------------------------------------------
-
-if test "$cy_cv_threads_package" = FSU; then
- cat >> confdefs.h <<\EOF
-#define USE_FSU_PTHREADS 1
-EOF
-
- else if test "$cy_cv_threads_package" = COOP; then
- cat >> confdefs.h <<\EOF
-#define USE_COOP_THREADS 1
-EOF
-
- else if test "$cy_cv_threads_package" = MIT; then
- cat >> confdefs.h <<\EOF
-#define USE_MIT_PTHREADS 1
-EOF
-
- else if test "$cy_cv_threads_package" = PCthreads; then
- cat >> confdefs.h <<\EOF
-#define USE_PCTHREADS_PTHREADS 1
-EOF
-
- else if test "$cy_cv_threads_package" = unknown; then
- { echo "configure: error: "cannot find threads installation"" 1>&2; exit 1; }
- fi
- fi
- fi
- fi
-fi
-
-if test "$cy_cv_threads_package" != ""; then
- cat >> confdefs.h <<\EOF
-#define USE_THREADS 1
-EOF
-
-fi
-
-## If we're using GCC, ask for aggressive warnings.
-case "$GCC" in
- yes ) CFLAGS="$CFLAGS -Wall -Wpointer-arith" ;;
-esac
-
-cat >> confdefs.h <<EOF
-#define GUILE_MAJOR_VERSION "$GUILE_MAJOR_VERSION"
-EOF
-
-cat >> confdefs.h <<EOF
-#define GUILE_MINOR_VERSION "$GUILE_MINOR_VERSION"
-EOF
-
-cat >> confdefs.h <<EOF
-#define GUILE_VERSION "$GUILE_VERSION"
-EOF
-
-
-
-trap '' 1 2 15
-cat > confcache <<\EOF
-# This file is a shell script that caches the results of configure
-# tests run on this system so they can be shared between configure
-# scripts and configure runs. It is not useful on other systems.
-# If it contains results you don't want to keep, you may remove or edit it.
-#
-# By default, configure uses ./config.cache as the cache file,
-# creating it if it does not exist already. You can give configure
-# the --cache-file=FILE option to use a different cache file; that is
-# what configure does when it calls configure scripts in
-# subdirectories, so they share the cache.
-# Giving --cache-file=/dev/null disables caching, for debugging configure.
-# config.status only pays attention to the cache file if you give it the
-# --recheck option to rerun configure.
-#
-EOF
-# The following way of writing the cache mishandles newlines in values,
-# but we know of no workaround that is simple, portable, and efficient.
-# So, don't put newlines in cache variables' values.
-# Ultrix sh set writes to stderr and can't be redirected directly,
-# and sets the high bit in the cache file unless we assign to the vars.
-(set) 2>&1 |
- case `(ac_space=' '; set) 2>&1` in
- *ac_space=\ *)
- # `set' does not quote correctly, so add quotes (double-quote substitution
- # turns \\\\ into \\, and sed turns \\ into \).
- sed -n \
- -e "s/'/'\\\\''/g" \
- -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p"
- ;;
- *)
- # `set' quotes correctly as required by POSIX, so do not add quotes.
- sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p'
- ;;
- esac >> confcache
-if cmp -s $cache_file confcache; then
- :
-else
- if test -w $cache_file; then
- echo "updating cache $cache_file"
- cat confcache > $cache_file
- else
- echo "not updating unwritable cache $cache_file"
- fi
-fi
-rm -f confcache
-
-trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
-
-test "x$prefix" = xNONE && prefix=$ac_default_prefix
-# Let make expand exec_prefix.
-test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
-
-# Any assignment to VPATH causes Sun make to only execute
-# the first set of double-colon rules, so remove it if not needed.
-# If there is a colon in the path, we need to keep it.
-if test "x$srcdir" = x.; then
- ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d'
-fi
-
-trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15
-
-DEFS=-DHAVE_CONFIG_H
-
-# Without the "./", some shells look in PATH for config.status.
-: ${CONFIG_STATUS=./config.status}
-
-echo creating $CONFIG_STATUS
-rm -f $CONFIG_STATUS
-cat > $CONFIG_STATUS <<EOF
-#! /bin/sh
-# Generated automatically by configure.
-# Run this file to recreate the current configuration.
-# This directory was configured as follows,
-# on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
-#
-# $0 $ac_configure_args
-#
-# Compiler output produced by configure, useful for debugging
-# configure, is in ./config.log if it exists.
-
-ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]"
-for ac_option
-do
- case "\$ac_option" in
- -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
- echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
- exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
- -version | --version | --versio | --versi | --vers | --ver | --ve | --v)
- echo "$CONFIG_STATUS generated by autoconf version 2.12"
- exit 0 ;;
- -help | --help | --hel | --he | --h)
- echo "\$ac_cs_usage"; exit 0 ;;
- *) echo "\$ac_cs_usage"; exit 1 ;;
- esac
-done
-
-ac_given_srcdir=$srcdir
-ac_given_INSTALL="$INSTALL"
-
-trap 'rm -fr `echo "Makefile fd.h guile-snarf scmconfig.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
-EOF
-cat >> $CONFIG_STATUS <<EOF
-
-# Protect against being on the right side of a sed subst in config.status.
-sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g;
- s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF
-$ac_vpsub
-$extrasub
-s%@CFLAGS@%$CFLAGS%g
-s%@CPPFLAGS@%$CPPFLAGS%g
-s%@CXXFLAGS@%$CXXFLAGS%g
-s%@DEFS@%$DEFS%g
-s%@LDFLAGS@%$LDFLAGS%g
-s%@LIBS@%$LIBS%g
-s%@exec_prefix@%$exec_prefix%g
-s%@prefix@%$prefix%g
-s%@program_transform_name@%$program_transform_name%g
-s%@bindir@%$bindir%g
-s%@sbindir@%$sbindir%g
-s%@libexecdir@%$libexecdir%g
-s%@datadir@%$datadir%g
-s%@sysconfdir@%$sysconfdir%g
-s%@sharedstatedir@%$sharedstatedir%g
-s%@localstatedir@%$localstatedir%g
-s%@libdir@%$libdir%g
-s%@includedir@%$includedir%g
-s%@oldincludedir@%$oldincludedir%g
-s%@infodir@%$infodir%g
-s%@mandir@%$mandir%g
-s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g
-s%@INSTALL_DATA@%$INSTALL_DATA%g
-s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g
-s%@PACKAGE@%$PACKAGE%g
-s%@VERSION@%$VERSION%g
-s%@SET_MAKE@%$SET_MAKE%g
-s%@module@%$module%g
-s%@CC@%$CC%g
-s%@CPP@%$CPP%g
-s%@RANLIB@%$RANLIB%g
-s%@LIBOBJS@%$LIBOBJS%g
-s%@FD_SETTER@%$FD_SETTER%g
-
-CEOF
-EOF
-
-cat >> $CONFIG_STATUS <<\EOF
-
-# Split the substitutions into bite-sized pieces for seds with
-# small command number limits, like on Digital OSF/1 and HP-UX.
-ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script.
-ac_file=1 # Number of current file.
-ac_beg=1 # First line for current file.
-ac_end=$ac_max_sed_cmds # Line after last line for current file.
-ac_more_lines=:
-ac_sed_cmds=""
-while $ac_more_lines; do
- if test $ac_beg -gt 1; then
- sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file
- else
- sed "${ac_end}q" conftest.subs > conftest.s$ac_file
- fi
- if test ! -s conftest.s$ac_file; then
- ac_more_lines=false
- rm -f conftest.s$ac_file
- else
- if test -z "$ac_sed_cmds"; then
- ac_sed_cmds="sed -f conftest.s$ac_file"
- else
- ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file"
- fi
- ac_file=`expr $ac_file + 1`
- ac_beg=$ac_end
- ac_end=`expr $ac_end + $ac_max_sed_cmds`
- fi
-done
-if test -z "$ac_sed_cmds"; then
- ac_sed_cmds=cat
-fi
-EOF
-
-cat >> $CONFIG_STATUS <<EOF
-
-CONFIG_FILES=\${CONFIG_FILES-"Makefile fd.h guile-snarf"}
-EOF
-cat >> $CONFIG_STATUS <<\EOF
-for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
- # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
- case "$ac_file" in
- *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'`
- ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
- *) ac_file_in="${ac_file}.in" ;;
- esac
-
- # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories.
-
- # Remove last slash and all that follows it. Not all systems have dirname.
- ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
- if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
- # The file is in a subdirectory.
- test ! -d "$ac_dir" && mkdir "$ac_dir"
- ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`"
- # A "../" for each directory in $ac_dir_suffix.
- ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'`
- else
- ac_dir_suffix= ac_dots=
- fi
-
- case "$ac_given_srcdir" in
- .) srcdir=.
- if test -z "$ac_dots"; then top_srcdir=.
- else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;;
- /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;;
- *) # Relative path.
- srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix"
- top_srcdir="$ac_dots$ac_given_srcdir" ;;
- esac
-
- case "$ac_given_INSTALL" in
- [/$]*) INSTALL="$ac_given_INSTALL" ;;
- *) INSTALL="$ac_dots$ac_given_INSTALL" ;;
- esac
-
- echo creating "$ac_file"
- rm -f "$ac_file"
- configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
- case "$ac_file" in
- *Makefile*) ac_comsub="1i\\
-# $configure_input" ;;
- *) ac_comsub= ;;
- esac
-
- ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
- sed -e "$ac_comsub
-s%@configure_input@%$configure_input%g
-s%@srcdir@%$srcdir%g
-s%@top_srcdir@%$top_srcdir%g
-s%@INSTALL@%$INSTALL%g
-" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file
-fi; done
-rm -f conftest.s*
-
-# These sed commands are passed to sed as "A NAME B NAME C VALUE D", where
-# NAME is the cpp macro being defined and VALUE is the value it is being given.
-#
-# ac_d sets the value in "#define NAME VALUE" lines.
-ac_dA='s%^\([ ]*\)#\([ ]*define[ ][ ]*\)'
-ac_dB='\([ ][ ]*\)[^ ]*%\1#\2'
-ac_dC='\3'
-ac_dD='%g'
-# ac_u turns "#undef NAME" with trailing blanks into "#define NAME VALUE".
-ac_uA='s%^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)'
-ac_uB='\([ ]\)%\1#\2define\3'
-ac_uC=' '
-ac_uD='\4%g'
-# ac_e turns "#undef NAME" without trailing blanks into "#define NAME VALUE".
-ac_eA='s%^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)'
-ac_eB='$%\1#\2define\3'
-ac_eC=' '
-ac_eD='%g'
-
-if test "${CONFIG_HEADERS+set}" != set; then
-EOF
-cat >> $CONFIG_STATUS <<EOF
- CONFIG_HEADERS="scmconfig.h"
-EOF
-cat >> $CONFIG_STATUS <<\EOF
-fi
-for ac_file in .. $CONFIG_HEADERS; do if test "x$ac_file" != x..; then
- # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
- case "$ac_file" in
- *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'`
- ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
- *) ac_file_in="${ac_file}.in" ;;
- esac
-
- echo creating $ac_file
-
- rm -f conftest.frag conftest.in conftest.out
- ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
- cat $ac_file_inputs > conftest.in
-
-EOF
-
-# Transform confdefs.h into a sed script conftest.vals that substitutes
-# the proper values into config.h.in to produce config.h. And first:
-# Protect against being on the right side of a sed subst in config.status.
-# Protect against being in an unquoted here document in config.status.
-rm -f conftest.vals
-cat > conftest.hdr <<\EOF
-s/[\\&%]/\\&/g
-s%[\\$`]%\\&%g
-s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%${ac_dA}\1${ac_dB}\1${ac_dC}\2${ac_dD}%gp
-s%ac_d%ac_u%gp
-s%ac_u%ac_e%gp
-EOF
-sed -n -f conftest.hdr confdefs.h > conftest.vals
-rm -f conftest.hdr
-
-# This sed command replaces #undef with comments. This is necessary, for
-# example, in the case of _POSIX_SOURCE, which is predefined and required
-# on some systems where configure will not decide to define it.
-cat >> conftest.vals <<\EOF
-s%^[ ]*#[ ]*undef[ ][ ]*[a-zA-Z_][a-zA-Z_0-9]*%/* & */%
-EOF
-
-# Break up conftest.vals because some shells have a limit on
-# the size of here documents, and old seds have small limits too.
-
-rm -f conftest.tail
-while :
-do
- ac_lines=`grep -c . conftest.vals`
- # grep -c gives empty output for an empty file on some AIX systems.
- if test -z "$ac_lines" || test "$ac_lines" -eq 0; then break; fi
- # Write a limited-size here document to conftest.frag.
- echo ' cat > conftest.frag <<CEOF' >> $CONFIG_STATUS
- sed ${ac_max_here_lines}q conftest.vals >> $CONFIG_STATUS
- echo 'CEOF
- sed -f conftest.frag conftest.in > conftest.out
- rm -f conftest.in
- mv conftest.out conftest.in
-' >> $CONFIG_STATUS
- sed 1,${ac_max_here_lines}d conftest.vals > conftest.tail
- rm -f conftest.vals
- mv conftest.tail conftest.vals
-done
-rm -f conftest.vals
-
-cat >> $CONFIG_STATUS <<\EOF
- rm -f conftest.frag conftest.h
- echo "/* $ac_file. Generated automatically by configure. */" > conftest.h
- cat conftest.in >> conftest.h
- rm -f conftest.in
- if cmp -s $ac_file conftest.h 2>/dev/null; then
- echo "$ac_file is unchanged"
- rm -f conftest.h
- else
- # Remove last slash and all that follows it. Not all systems have dirname.
- ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
- if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
- # The file is in a subdirectory.
- test ! -d "$ac_dir" && mkdir "$ac_dir"
- fi
- rm -f $ac_file
- mv conftest.h $ac_file
- fi
-fi; done
-
-EOF
-cat >> $CONFIG_STATUS <<EOF
-
-
-EOF
-cat >> $CONFIG_STATUS <<\EOF
-test -z "$CONFIG_HEADER" || echo timestamp > stamp-h
-chmod +x guile-snarf
-exit 0
-EOF
-chmod +x $CONFIG_STATUS
-rm -fr confdefs* $ac_clean_files
-test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
-
-
diff --git a/libguile/configure.in b/libguile/configure.in
deleted file mode 100644
index d7ba37bd3..000000000
--- a/libguile/configure.in
+++ /dev/null
@@ -1,218 +0,0 @@
-AC_INIT(eval.c)
-AM_CONFIG_HEADER(scmconfig.h)
-AM_INIT_GUILE_MODULE(libguile)
-
-#--------------------------------------------------------------------
-#
-# User options
-#
-#--------------------------------------------------------------------
-
-AC_ARG_ENABLE(debug,
-[ --disable-debug Don't include debugging support])
-if test "$enableval" != n && test "$enableval" != no; then
- AC_DEFINE(DEBUG_EXTENSIONS)
- AC_DEFINE(READER_EXTENSIONS)
- LIBOBJS="backtrace.o stacks.o debug.o srcprop.o $LIBOBJS"
-fi
-
-AC_ARG_ENABLE(dynamic-linking,
- [ --enable-dynamic-linking Include support for dynamic linking])
-if test "$enableval" != n && test "$enableval" != no && test "$enableval" != ""; then
- AC_DEFINE(DYNAMIC_LINKING)
-fi
-
-#--------------------------------------------------------------------
-
-AC_PROG_CC
-AC_PROG_CPP
-AC_PROG_RANLIB
-
-AC_AIX
-AC_ISC_POSIX
-AC_MINIX
-
-CY_AC_WITH_THREADS
-
-AC_C_CONST
-
-AC_HEADER_STDC
-AC_HEADER_DIRENT
-AC_HEADER_TIME
-AC_HEADER_SYS_WAIT
-AC_CHECK_HEADERS(libc.h limits.h malloc.h memory.h string.h sys/ioctl.h sys/select.h sys/time.h sys/timeb.h sys/times.h sys/types.h sys/utime.h time.h unistd.h utime.h)
-GUILE_HEADER_LIBC_WITH_UNISTD
-
-AC_TYPE_GETGROUPS
-AC_TYPE_SIGNAL
-AC_TYPE_MODE_T
-
-AC_CHECK_FUNCS(ctermid ftime getcwd geteuid lstat mkdir mknod nice putenv readlink rename rmdir select setegid seteuid setlocale setpgid setsid strftime strptime symlink sync tcgetpgrp tcsetpgrp times uname waitpid)
-
-AC_REPLACE_FUNCS(inet_aton strerror)
-
-AC_STRUCT_ST_RDEV
-AC_STRUCT_ST_BLKSIZE
-AC_STRUCT_ST_BLOCKS
-GUILE_STRUCT_UTIMBUF
-
-# Checks for dynamic linking
-AC_CHECK_LIB(dl,dlopen)
-AC_CHECK_LIB(dld,dld_link)
-AC_CHECK_FUNCS(shl_load)
-
-#--------------------------------------------------------------------
-#
-# Which way does the stack grow?
-#
-#--------------------------------------------------------------------
-
-AC_TRY_RUN(aux (l) unsigned long l;
- { int x; exit (l >= ((unsigned long)&x)); }
- main () { int q; aux((unsigned long)&q); },
- AC_DEFINE(SCM_STACK_GROWS_UP),,AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h.in))
-
-
-AC_TRY_RUN(main () { exit (sizeof(float) != sizeof(long)); },
- AC_DEFINE(SCM_SINGLES),,AC_DEFINE(SCM_SINGLES)
- AC_MSG_WARN(Guessing that sizeof(long) == sizeof(float) -- see scmconfig.h.in))
-
-AC_MSG_CHECKING(for struct linger)
-AC_CACHE_VAL(scm_cv_struct_linger,
- AC_TRY_COMPILE([#include <sys/socket.h>],
- [struct linger lgr; lgr.l_linger = 100],
- scm_cv_struct_linger="yes",
- scm_cv_struct_linger="no"))
-AC_MSG_RESULT($scm_cv_struct_linger)
-if test $scm_cv_struct_linger = yes; then
- AC_DEFINE(HAVE_STRUCT_LINGER)
-fi
-
-#--------------------------------------------------------------------
-#
-# How can you violate a stdio abstraction by setting a stream's fd?
-#
-#--------------------------------------------------------------------
-
-FD_SETTER=""
-
-if test "x$FD_SETTER" = x; then
- AC_TRY_COMPILE(#include <stdio.h>
-, stdout->_file = 1,
- FD_SETTER="((F)->_file = (D))")
-fi
-
-if test "x$FD_SETTER" = x; then
- AC_TRY_COMPILE(#include <stdio.h>
-, stdout->_fileno,
- FD_SETTER="((F)->_fileno = (D))")
-fi
-
-dnl
-dnl Add FD_SETTER tests for other systems here. Your test should
-dnl try a particular style of assigning to the descriptor
-dnl field(s) of a FILE* and define FD_SETTER accordingly.
-dnl
-dnl The value of FD_SETTER is used as a macro body, as in:
-dnl
-dnl #define SET_FILE_FD_FIELD(F,D) @FD_SETTER@
-dnl
-dnl F is a FILE* and D a descriptor (int).
-dnl
-
-test "x$FD_SETTER" != x && AC_DEFINE(HAVE_FD_SETTER)
-
-#--------------------------------------------------------------------
-# How to find out whether a FILE structure contains buffered data.
-# From Tk we have the following list:
-# _cnt: Most UNIX systems
-# __cnt: HPUX
-# _r: BSD
-# readCount: Sprite
-# Or, in GNU libc there are two fields, _gptr and _egptr, which
-# have to be compared.
-# These can also be known as _IO_read_ptr and _IO_read_end.
-#--------------------------------------------------------------------
-
-AC_MSG_CHECKING(how to get buffer char count from FILE structure)
-AC_CACHE_VAL(scm_cv_struct_file_count,
- AC_TRY_COMPILE([#include <stdio.h>],
- [FILE *f = stdin; f->_cnt = 0],
- scm_cv_struct_file_count="_cnt",
- AC_TRY_COMPILE([#include <stdio.h>],
- [FILE *f = stdin; f->_r = 0],
- scm_cv_struct_file_count="_r",
- AC_TRY_COMPILE([#include <stdio.h>],
- [FILE *f = stdin; f->readCount = 0],
- scm_cv_struct_file_count="readCount",
- scm_cv_struct_file_count=""))))
-if test "$scm_cv_struct_file_count"; then
- AC_MSG_RESULT($scm_cv_struct_file_count)
- AC_DEFINE_UNQUOTED(FILE_CNT_FIELD, $scm_cv_struct_file_count)
-else
-AC_CACHE_VAL(scm_cv_struct_file_gptr,
- AC_TRY_COMPILE([#include <stdio.h>],
- [FILE *f = stdin; f->_gptr = f->egptr;],
- scm_cv_struct_file_gptr=1,
- scm_cv_struct_file_gptr=""))
-if test "$scm_cv_struct_gptr"; then
- AC_MSG_RESULT(gptr)
- AC_DEFINE_UNQUOTED(FILE_CNT_GPTR, $scm_cv_struct_file_gptr)
-else
-AC_CACHE_VAL(scm_cv_struct_file_readptr,
- AC_TRY_COMPILE([#include <stdio.h>],
- [FILE *f = stdin; f->_IO_read_ptr = f->_IO_read_end;],
- scm_cv_struct_file_readptr=1))
-if test "$scm_cv_struct_file_readptr"; then
- AC_MSG_RESULT(read_ptr)
- AC_DEFINE_UNQUOTED(FILE_CNT_READPTR, $scm_cv_struct_file_readptr)
-fi
-fi
-fi
-
-#--------------------------------------------------------------------
-#
-# Flags for thread support
-#
-#--------------------------------------------------------------------
-
-dnl
-dnl Set the appropriate flags!
-dnl
-if test "$cy_cv_threads_package" = FSU; then
- AC_DEFINE(USE_FSU_PTHREADS, 1)
- else if test "$cy_cv_threads_package" = COOP; then
- AC_DEFINE(USE_COOP_THREADS, 1)
- else if test "$cy_cv_threads_package" = MIT; then
- AC_DEFINE(USE_MIT_PTHREADS, 1)
- else if test "$cy_cv_threads_package" = PCthreads; then
- AC_DEFINE(USE_PCTHREADS_PTHREADS, 1)
- else if test "$cy_cv_threads_package" = unknown; then
- AC_MSG_ERROR("cannot find threads installation")
- fi
- fi
- fi
- fi
-fi
-
-if test "$cy_cv_threads_package" != ""; then
- AC_DEFINE(USE_THREADS)
-fi
-
-## If we're using GCC, ask for aggressive warnings.
-case "$GCC" in
- yes ) CFLAGS="$CFLAGS -Wall -Wpointer-arith" ;;
-esac
-
-AC_DEFINE_UNQUOTED(GUILE_MAJOR_VERSION, "$GUILE_MAJOR_VERSION")
-AC_DEFINE_UNQUOTED(GUILE_MINOR_VERSION, "$GUILE_MINOR_VERSION")
-AC_DEFINE_UNQUOTED(GUILE_VERSION, "$GUILE_VERSION")
-
-AC_SUBST(FD_SETTER)
-AC_OUTPUT([Makefile fd.h guile-snarf], [chmod +x guile-snarf])
-
-dnl Local Variables:
-dnl comment-start: "dnl "
-dnl comment-end: ""
-dnl comment-start-skip: "\\bdnl\\b\\s *"
-dnl End:
diff --git a/libguile/continuations.c b/libguile/continuations.c
deleted file mode 100644
index f04912c8a..000000000
--- a/libguile/continuations.c
+++ /dev/null
@@ -1,212 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "stackchk.h"
-#ifdef DEBUG_EXTENSIONS
-#include "debug.h"
-#endif
-#include "dynwind.h"
-
-#include "continuations.h"
-
-
-/* {Continuations}
- */
-
-static char s_cont[] = "continuation";
-
-
-SCM
-scm_make_cont (answer)
- SCM * answer;
-{
- long j;
- SCM cont;
-
-#ifdef CHEAP_CONTINUATIONS
- SCM_NEWCELL (cont);
- *answer = cont;
- SCM_DEFER_INTS;
- SCM_SETJMPBUF (cont, scm_must_malloc ((long) sizeof (scm_contregs), s_cont));
- SCM_SETCAR (cont, scm_tc7_contin);
- SCM_DYNENV (cont) = scm_dynwinds;
- SCM_THROW_VALUE = SCM_EOL;
- SCM_BASE (cont) = SCM_BASE (rootcont);
- SCM_SEQ (cont) = SCM_SEQ (rootcont);
- SCM_ALLOW_INTS;
-#else
- register SCM_STACKITEM *src, *dst;
-
-#if 0
- {
- SCM winds;
-
- for (winds = scm_dynwinds; winds != SCM_EOL; winds = SCM_CDR (winds))
- {
- if (SCM_INUMP (SCM_CAR (winds)))
- {
- scm_relocate_chunk_to_heap (SCM_CAR (winds));
- }
- }
- }
-#endif
-
- SCM_NEWCELL (cont);
- *answer = cont;
- SCM_DEFER_INTS;
- SCM_FLUSH_REGISTER_WINDOWS;
- j = scm_stack_size (SCM_BASE (scm_rootcont));
- SCM_SETJMPBUF (cont,
- scm_must_malloc ((long) (sizeof (scm_contregs) + j * sizeof (SCM_STACKITEM)),
- s_cont));
- SCM_SETLENGTH (cont, j, scm_tc7_contin);
- SCM_DYNENV (cont) = scm_dynwinds;
- SCM_THROW_VALUE (cont) = SCM_EOL;
- src = SCM_BASE (cont) = SCM_BASE (scm_rootcont);
- SCM_SEQ (cont) = SCM_SEQ (scm_rootcont);
- SCM_ALLOW_INTS;
-#ifndef SCM_STACK_GROWS_UP
- src -= SCM_LENGTH (cont);
-#endif /* ndef SCM_STACK_GROWS_UP */
- dst = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs));
- for (j = SCM_LENGTH (cont); 0 <= --j;)
- *dst++ = *src++;
-#endif /* def CHEAP_CONTINUATIONS */
-#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (cont) = scm_last_debug_frame;
-#endif
- return cont;
-}
-
-/* Grow the stack so that there is room */
-/* to copy in the continuation. Then */
-#ifndef CHEAP_CONTINUATIONS
-
-static void grow_throw SCM_P ((SCM *a));
-
-static void
-grow_throw (a)
- SCM *a;
-{ /* retry the throw. */
- SCM growth[100];
- growth[0] = a[0];
- growth[1] = a[1];
- growth[2] = a[2] + 1;
- growth[3] = (SCM) a;
- scm_dynthrow (growth);
-}
-#endif /* ndef CHEAP_CONTINUATIONS */
-
-
-void
-scm_dynthrow (a)
- SCM *a;
-{
- SCM cont = a[0], val = a[1];
-#ifndef CHEAP_CONTINUATIONS
- register long j;
- register SCM_STACKITEM *src, *dst = SCM_BASE (scm_rootcont);
-#ifdef SCM_STACK_GROWS_UP
- if (a[2] && (a - ((SCM *) a[3]) < 100))
-#else
- if (a[2] && (((SCM *) a[3]) - a < 100))
-#endif
- fputs ("grow_throw: check if SCM growth[100]; being optimized out\n",
- stderr);
- /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n",
- a[2], (((SCM *)a[3]) - a)); */
-#ifdef SCM_STACK_GROWS_UP
- if (SCM_PTR_GE (dst + SCM_LENGTH (cont), (SCM_STACKITEM *) & a))
- grow_throw (a);
-#else
- dst -= SCM_LENGTH (cont);
- if (SCM_PTR_LE (dst, (SCM_STACKITEM *) & a))
- grow_throw (a);
-#endif /* def SCM_STACK_GROWS_UP */
- SCM_FLUSH_REGISTER_WINDOWS;
- src = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs));
- for (j = SCM_LENGTH (cont); 0 <= --j;)
- *dst++ = *src++;
-#ifdef sparc /* clear out stack up to this stackframe */
- /* maybe this would help, maybe not */
-/* bzero((void *)&a, sizeof(SCM_STACKITEM) * (((SCM_STACKITEM *)&a) -
- (dst - SCM_LENGTH(cont)))) */
-#endif
-#endif /* ndef CHEAP_CONTINUATIONS */
-#ifdef DEBUG_EXTENSIONS
- scm_last_debug_frame = SCM_DFRAME (cont);
-#endif
- SCM_THROW_VALUE(cont) = val;
- longjmp (SCM_JMPBUF (cont), 1);
-}
-
-
-SCM
-scm_call_continuation (cont, val)
- SCM cont;
- SCM val;
-{
- SCM a[3];
- a[0] = cont;
- a[1] = val;
- a[2] = 0;
- if ( (SCM_SEQ (cont) != SCM_SEQ (scm_rootcont))
- || (SCM_BASE (cont) != SCM_BASE (scm_rootcont))) /* base compare not needed */
- scm_wta (cont, "continuation from wrong top level", s_cont);
-
- scm_dowinds (SCM_DYNENV (cont),
- scm_ilength (scm_dynwinds) - scm_ilength (SCM_DYNENV (cont)));
-
- scm_dynthrow (a);
- return SCM_UNSPECIFIED; /* not reached */
-}
-
-
-
-void
-scm_init_continuations ()
-{
-#include "continuations.x"
-}
-
diff --git a/libguile/continuations.h b/libguile/continuations.h
deleted file mode 100644
index 0bd18296e..000000000
--- a/libguile/continuations.h
+++ /dev/null
@@ -1,78 +0,0 @@
-/* classes: h_files */
-
-#ifndef CONTINUATIONSH
-#define CONTINUATIONSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-
-typedef struct
-{
- SCM throw_value;
- jmp_buf jmpbuf;
- SCM dynenv;
- SCM_STACKITEM *base;
- unsigned long seq;
-
-#ifdef DEBUG_EXTENSIONS
- struct scm_debug_frame *dframe;
-#endif
-} scm_contregs;
-
-#define SCM_JMPBUF(x) (((scm_contregs *)SCM_CHARS(x))->jmpbuf)
-#define SCM_SETJMPBUF SCM_SETCDR
-#define SCM_DYNENV(x) (((scm_contregs *)SCM_CHARS(x))->dynenv)
-#define SCM_THROW_VALUE(x) (((scm_contregs *)SCM_CHARS(x))->throw_value)
-#define SCM_BASE(x) (((scm_contregs *)SCM_CHARS(x))->base)
-#define SCM_SEQ(x) (((scm_contregs *)SCM_CHARS(x))->seq)
-#define SCM_DFRAME(x) (((scm_contregs *)SCM_CHARS(x))->dframe)
-
-
-
-extern SCM scm_make_cont SCM_P ((SCM * answer));
-extern void scm_dynthrow SCM_P ((SCM *a));
-extern SCM scm_call_continuation SCM_P ((SCM cont, SCM val));
-extern void scm_init_continuations SCM_P ((void));
-
-#endif /* CONTINUATIONSH */
diff --git a/libguile/dynl-dl.c b/libguile/dynl-dl.c
deleted file mode 100644
index 7899b3245..000000000
--- a/libguile/dynl-dl.c
+++ /dev/null
@@ -1,212 +0,0 @@
-/* dynl-dl.c - dynamic linking for dlopen/dlsym
- *
- * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-/* "dynl.c" dynamically link&load object files.
- Author: Aubrey Jaffer
- Modified for libguile by Marius Vollmer */
-
-#include "_scm.h"
-#include "genio.h"
-#include "smob.h"
-
-#include <dlfcn.h>
-
-#define SHL(obj) ((void*)SCM_CDR(obj))
-
-#ifdef RTLD_LAZY /* Solaris 2. */
-# define DLOPEN_MODE RTLD_LAZY
-#else
-# define DLOPEN_MODE 1 /* Thats what it says in the man page. */
-#endif
-
-static scm_sizet frshl SCM_P ((SCM ptr));
-
-static scm_sizet
-frshl (ptr)
- SCM ptr;
-{
-#if 0
- /* Should freeing a shl close and possibly unmap the object file it */
- /* refers to? */
- if (SHL(ptr))
- dlclose (SHL(ptr));
-#endif
- return 0;
-}
-
-static int prinshl SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-
-static int
-prinshl (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_gen_puts (scm_regular_string, "#<dynamic-linked ", port);
- scm_intprint (SCM_CDR (exp), 16, port);
- scm_gen_putc ('>', port);
- return 1;
-}
-
-int scm_tc16_shl;
-static scm_smobfuns shlsmob = { scm_mark0, frshl, prinshl };
-
-SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link);
-
-SCM
-scm_dynamic_link (fname)
- SCM fname;
-{
- SCM z;
- void *handle;
-
- /* if FALSEP(fname) return fname; XXX - ? */
-
- fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
-
- SCM_DEFER_INTS;
- handle = dlopen (SCM_CHARS (fname), DLOPEN_MODE);
- if (NULL == handle)
- scm_misc_error (s_dynamic_link, (char *)dlerror (), SCM_EOL);
- SCM_NEWCELL (z);
- SCM_SETCHARS (z, handle);
- SCM_SETCAR (z, scm_tc16_shl);
- SCM_ALLOW_INTS;
-
- return z;
-}
-
-static void *get_func SCM_P ((void *handle, char *func, char *subr));
-
-static void *
-get_func (handle, func, subr)
- void *handle;
- char *func;
- char *subr;
-{
- void *fptr;
- char *err;
-
- fptr = dlsym (handle, func);
- err = (char *)dlerror ();
- if (!fptr)
- scm_misc_error (subr, err? err : "symbol has NULL address", SCM_EOL);
- return fptr;
-}
-
-SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
-
-SCM
-scm_dynamic_call (symb, shl)
- SCM symb, shl;
-{
- void (*func) SCM_P ((void)) = 0;
-
- symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1);
- SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl,
- SCM_ARG2, s_dynamic_call);
-
- SCM_DEFER_INTS;
- func = get_func (SHL(shl), SCM_CHARS (symb), s_dynamic_call);
- SCM_ALLOW_INTS;
-
- (*func) ();
-
- return SCM_BOOL_T;
-}
-
-SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
-
-SCM
-scm_dynamic_args_call (symb, shl, args)
- SCM symb, shl, args;
-{
- int i, argc;
- char **argv;
- int (*func) SCM_P ((int argc, char **argv)) = 0;
-
- symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1);
- SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl,
- SCM_ARG2, s_dynamic_args_call);
-
- SCM_DEFER_INTS;
- func = get_func (SHL(shl), SCM_CHARS (symb), s_dynamic_args_call);
- argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
- SCM_ARG3);
- SCM_ALLOW_INTS;
-
- i = (*func) (argc, argv);
-
- SCM_DEFER_INTS;
- scm_must_free_argv(argv);
- SCM_ALLOW_INTS;
- return SCM_MAKINUM(0L+i);
-}
-
-SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
-
-SCM
-scm_dynamic_unlink (shl)
- SCM shl;
-{
- int status;
-
- SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl,
- SCM_ARG1, s_dynamic_unlink);
-
- SCM_DEFER_INTS;
- status = dlclose (SHL(shl));
- SCM_SETCHARS (shl, NULL);
- SCM_ALLOW_INTS;
-
- if (status)
- scm_misc_error (s_dynamic_unlink, (char *)dlerror (), SCM_EOL);
- return SCM_BOOL_T;
-}
-
-void
-scm_init_dynamic_linking ()
-{
- scm_tc16_shl = scm_newsmob (&shlsmob);
-#include "dynl.x"
-}
diff --git a/libguile/dynl-dld.c b/libguile/dynl-dld.c
deleted file mode 100644
index aba8b93ed..000000000
--- a/libguile/dynl-dld.c
+++ /dev/null
@@ -1,187 +0,0 @@
-/* dynl-dld.c - dynamic linking with dld
- *
- * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-/* "dynl.c" dynamically link&load object files.
- Author: Aubrey Jaffer
- Modified for libguile by Marius Vollmer */
-
-#include "_scm.h"
-#include "genio.h"
-#include "smob.h"
-
-#include "dld.h"
-
-static void listundef SCM_P ((void));
-
-static void
-listundefs ()
-{
- int i;
- char **undefs = dld_list_undefined_sym();
- puts(" undefs:");
- for(i = dld_undefined_sym_count;i--;) {
- putc('"', stdout);
- fputs(undefs[i], stdout);
- puts("\"");
- }
- free(undefs);
-}
-
-SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link);
-
-SCM
-scm_dynamic_link (fname)
- SCM fname;
-{
- int status;
-
- fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
-
- SCM_DEFER_INTS;
- status = dld_link (SCM_CHARS (fname));
- SCM_ALLOW_INTS;
- if (status)
- scm_misc_error (s_dynamic_link, dld_strerror (status), SCM_EOL);
- return fname;
-}
-
-static void *get_func SCM_P ((char *subr, char *fname));
-
-static void *
-get_func (subr, fname)
- char *subr;
- char *fname;
-{
- void *func;
-
- if (!dld_function_executable_p (func)) {
- listundefs ();
- scm_misc_error (subr, "unresolved symbols remain", SCM_EOL);
- }
- func = (void *) dld_get_func (func);
- if (func == 0)
- scm_misc_error (subr, dld_strerror (dld_errno), SCM_EOL);
- return func;
-}
-
-SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
-
-SCM
-scm_dynamic_call (symb, shl)
- SCM symb;
- SCM shl;
-{
- void (*func)() = 0;
-
- symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1);
-
- SCM_DEFER_INTS;
- func = get_func (s_dynamic_call, SCM_CHARS (symb));
- SCM_ALLOW_INST;
- (*func) ();
- return SCM_BOOL_T;
-}
-
-SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
-
-SCM
-scm_dynamic_args_call (symb, shl, args)
- SCM symb, shl, args;
-{
- int i, argc;
- char **argv;
- int (*func) SCM_P ((int argc, char **argv)) = 0;
-
- symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1);
-
- SCM_DEFER_INTS;
- func = get_func (SCM_CHARS (symb), s_dynamic_args_call);
- argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
- SCM_ARG3);
- SCM_ALLOW_INTS;
-
- i = (*func) (argc, argv);
-
- SCM_DEFER_INTS;
- scm_must_free_argv(argv);
- SCM_ALLOW_INTS;
- return SCM_MAKINUM(0L+i);
-}
-
-SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
-
-SCM
-scm_dynamic_unlink(fname)
- SCM fname;
-{
- int status;
-
- fname = scm_coerce_rostring (fname, s_dynamic_unlink, SCM_ARG1);
-
- SCM_DEFER_INTS;
- status = dld_unlink_by_file (SCM_CHARS (fname), 1);
- SCM_ALLOW_INTS;
-
- if (status)
- scm_misc_error (s_dynamic_unlink, dld_strerror (status), SCM_EOL);
- return SCM_BOOL_T;
-}
-
-void
-scm_init_dynamic_linking ()
-{
-#ifndef RTL
- if (!execpath)
- execpath = dld_find_executable (SCM_CHARS (SCM_CAR (progargs)));
- if (dld_init (SCM_CHARS (SCM_CAR (progargs)))) {
- dld_perror("DLD");
- return;
- }
-#endif
-
-#include "dynl.x"
-
-#ifdef DLD_DYNCM /* XXX - what's this? */
- add_feature("dld:dyncm");
-#endif
-}
diff --git a/libguile/dynl-shl.c b/libguile/dynl-shl.c
deleted file mode 100644
index b8e474484..000000000
--- a/libguile/dynl-shl.c
+++ /dev/null
@@ -1,172 +0,0 @@
-/* dynl-shl.c - dynamic linking with shl_load (HP-UX)
- *
- * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-/* "dynl.c" dynamically link&load object files.
- Author: Aubrey Jaffer
- Modified for libguile by Marius Vollmer */
-
-#include "_scm.h"
-#include "genio.h"
-#include "smob.h"
-
-#include "dl.h"
-
-#define SHL(obj) ((shl_t*)SCM_CDR(obj))
-
-static int printshl SCM_P ((SCM exp, SCM port, scm_printstate *pstate));
-
-static int
-prinshl (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_printstate *pstate;
-{
- scm_gen_puts (scm_regular_string, "#<dynamic-linked ", port);
- scm_intprint (SCM_CDR (exp), 16, port);
- scm_gen_putc ('>', port);
- return 1;
-}
-
-int scm_tc16_shl;
-static scm_smobfuns shlsmob = { scm_mark0, scm_free0, prinshl };
-
-SCM_PROC (s_dynamic_link, "dynamic-link", 1, 0, 0, scm_dynamic_link);
-
-SCM
-scm_dynamic_link (fname)
- SCM fname;
-{
- SCM z;
- shl_t shl;
-
- fname = scm_coerce_rostring (fname, s_dynamic_link, SCM_ARG1);
-
- SCM_DEFER_INTS;
- shl = shl_load (SCM_CHARS (fname), BIND_DEFERRED , 0L);
- if (NULL==shl)
- scm_misc_error (s_dynamic_link, "dynamic linking failed", SCM_EOL);
- SCM_NEWCELL (z);
- SCM_SETCHARS (z, shl);
- SCM_SETCAR (z, scm_tc16_shl);
- SCM_ALLOW_INTS;
-
- return z;
-}
-
-SCM_PROC (s_dynamic_call, "dynamic-call", 2, 0, 0, scm_dynamic_call);
-
-SCM
-scm_dynamic_call (symb, shl)
- SCM symb, shl;
-{
- void (*func)() = 0;
- int i;
-
- symb = scm_coerce_rostring (symb, s_dynamic_call, SCM_ARG1);
- SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl, SCM_ARG2,
- s_dynamic_call);
-
- SCM_DEFER_INTS;
- if (shl_findsym (&SHL(shl), SCM_CHARS(symb), TYPE_PROCEDURE, &func))
- scm_misc_error (s_dynamic_call, "undefined function",
- scm_cons (symb, SCM_EOL));
- SCM_ALLOW_INTS;
-
- (*func) ();
- return SCM_BOOL_T;
-}
-
-SCM_PROC (s_dynamic_args_call, "dynamic-args-call", 3, 0, 0, scm_dynamic_args_call);
-
-SCM
-scm_dynamic_args_call (symb, shl, args)
- SCM symb, shl, args;
-{
- int i, argc;
- char **argv;
- int (*func) SCM_P ((int argc, char **argv)) = 0;
-
- symb = scm_coerce_rostring (symb, s_dynamic_args_call, SCM_ARG1);
- SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR(shl) == scm_tc16_shl, shl, SCM_ARG2,
- s_dynamic_args_call);
-
- SCM_DEFER_INTS;
- if (shl_findsym(&SHL(shl), SCM_CHARS(symb), TYPE_PROCEDURE, &func))
- scm_misc_error (s_dynamic_call, "undefined function: %s",
- scm_cons (symb, SCM_EOL));
- argv = scm_make_argv_from_stringlist (args, &argc, s_dynamic_args_call,
- SCM_ARG3);
- SCM_ALLOW_INTS;
-
- i = (*func) (argc, argv);
-
- SCM_DEFER_INTS;
- scm_must_free_argv (argv);
- SCM_ALLOW_INTS;
- return SCM_MAKINUM (0L+i);
-}
-
-SCM_PROC (s_dynamic_unlink, "dynamic-unlink", 1, 0, 0, scm_dynamic_unlink);
-
-SCM
-scm_dynamic_unlink (shl)
- SCM shl;
-{
- int status;
- SCM_ASSERT (SCM_NIMP (shl) && SCM_CAR (shl) == scm_tc16_shl, shl,
- SCM_ARG1, s_dynamic_unlink);
-
- SCM_DEFER_INTS;
- status = shl_unload (SHL (shl));
- SCM_ALLOW_INTS;
- if (!status)
- return SCM_BOOL_T;
- return SCM_BOOL_F;
-}
-
-void
-scm_init_dynamic_linking ()
-{
- scm_tc16_shl = scm_newsmob (&shlsmob);
-#include "dynl.x"
-}
diff --git a/libguile/dynl-vms.c b/libguile/dynl-vms.c
deleted file mode 100644
index 322839cbc..000000000
--- a/libguile/dynl-vms.c
+++ /dev/null
@@ -1,106 +0,0 @@
-/* dynl-vms.c - dynamic linking for VMS, not yet ported
- *
- * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-/* "dynl.c" dynamically link&load object files.
- Author: Aubrey Jaffer
- (Not yet) modified for libguile by Marius Vollmer */
-
-/* We should try to implement dynamic-link/dynamic-call for VMS,
- too. */
-
-#include "_scm.h"
-
-/* This permits dynamic linking. For example, the procedure of 0 arguments
- from a file could be the initialization procedure.
- (vms:dynamic-link-call "MYDISK:[MYDIR].EXE" "foo" "INIT_FOO")
- The first argument specifies the directory where the file specified
- by the second argument resides. The current directory would be
- "SYS$DISK:[].EXE".
- The second argument cannot contain any punctuation.
- The third argument probably needs to be uppercased to mimic the VMS linker.
- */
-
-# include <descrip.h>
-# include <ssdef.h>
-# include <rmsdef.h>
-
-struct dsc$descriptor *descriptorize(x, buff)
- struct dsc$descriptor *x;
- SCM buff;
-{(*x).dsc$w_length = LENGTH(buff);
- (*x).dsc$a_pointer = CHARS(buff);
- (*x).dsc$b_class = DSC$K_CLASS_S;
- (*x).dsc$b_dtype = DSC$K_DTYPE_T;
- return(x);}
-
-static char s_dynl[] = "vms:dynamic-link-call";
-SCM dynl(dir, symbol, fname)
- SCM dir, symbol, fname;
-{
- struct dsc$descriptor fnamed, symbold, dird;
- void (*fcn)();
- long retval;
- ASSERT(IMP(dir) || STRINGP(dir), dir, ARG1, s_dynl);
- ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG2, s_dynl);
- ASSERT(NIMP(symbol) && STRINGP(symbol), symbol, ARG3, s_dynl);
- descriptorize(&fnamed, fname);
- descriptorize(&symbold, symbol);
- DEFER_INTS;
- retval = lib$find_image_symbol(&fnamed, &symbold, &fcn,
- IMP(dir) ? 0 : descriptorize(&dird, dir));
- if (SS$_NORMAL != retval) {
- /* wta(MAKINUM(retval), "vms error", s_dynl); */
- ALLOW_INTS;
- return BOOL_F;
- }
- ALLOW_INTS;
-/* *loc_loadpath = dir; */
- (*fcn)();
-/* *loc_loadpath = oloadpath; */
- return BOOL_T;
-}
-
-void init_dynl()
-{
- make_subr(s_dynl, tc7_subr_3, dynl);
-}
diff --git a/libguile/dynl.c b/libguile/dynl.c
deleted file mode 100644
index 800de3d7b..000000000
--- a/libguile/dynl.c
+++ /dev/null
@@ -1,147 +0,0 @@
-/* dynl.c - dynamic linking
- *
- * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-/* "dynl.c" dynamically link&load object files.
- Author: Aubrey Jaffer
- Modified for libguile by Marius Vollmer */
-
-#include "_scm.h"
-
-/* Converting a list of SCM strings into a argv-style array. You must
- have ints disabled for the whole lifetime of the created argv (from
- before MAKE_ARGV_FROM_STRINGLIST until after
- MUST_FREE_ARGV). Atleast this is was the documentation for
- MAKARGVFROMSTRS says, it isn't really used that way.
-
- This code probably belongs into strings.c */
-
-static char **scm_make_argv_from_stringlist SCM_P ((SCM args, int *argcp,
- char *subr, int argn));
-
-static char **
-scm_make_argv_from_stringlist (args, argcp, subr, argn)
- SCM args;
- int *argcp;
- char *subr;
- int argn;
-{
- char **argv;
- int argc, i;
-
- argc = scm_ilength(args);
- argv = (char **) scm_must_malloc ((1L+argc)*sizeof(char *), subr);
- for(i = 0; SCM_NNULLP (args); args = SCM_CDR (args), i++) {
- size_t len;
- char *dst, *src;
- SCM str = SCM_CAR (args);
-
- SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, argn, subr);
- len = 1 + SCM_ROLENGTH (str);
- dst = (char *) scm_must_malloc ((long)len, subr);
- src = SCM_ROCHARS (str);
- while (len--)
- dst[len] = src[len];
- argv[i] = dst;
- }
-
- if (argcp)
- *argcp = argc;
- argv[argc] = 0;
- return argv;
-}
-
-static void scm_must_free_argv SCM_P ((char **argv));
-
-static void
-scm_must_free_argv(argv)
- char **argv;
-{
- char **av = argv;
- while(!(*av))
- free(*(av++));
- free(argv);
-}
-
-/* Coerce an arbitrary readonly-string into a zero-terminated string.
- */
-
-static SCM scm_coerce_rostring SCM_P ((SCM rostr, char *subr, int argn));
-
-static SCM
-scm_coerce_rostring (rostr, subr, argn)
- SCM rostr;
- char *subr;
- int argn;
-{
- SCM_ASSERT (SCM_NIMP (rostr) && SCM_ROSTRINGP (rostr), rostr, argn, subr);
- if (SCM_SUBSTRP (rostr))
- rostr = scm_makfromstr (SCM_ROCHARS (rostr), SCM_ROLENGTH (rostr), 0);
- return rostr;
-}
-
-/* Dispatch to the system dependent files
- */
-
-#ifdef DYNAMIC_LINKING
-#ifdef HAVE_LIBDL
-#include "dynl-dl.c"
-#else
-#ifdef HAVE_SHL_LOAD
-#include "dynl-shl.c"
-#else
-#ifdef HAVE_DLD
-#include "dynl-dld.c"
-#else /* no dynamic linking available */
-void
-scm_init_dynamic_linking ()
-{
-}
-#endif
-#endif
-#endif
-#else /* dynamic linking disabled */
-void
-scm_init_dynamic_linking ()
-{
-}
-#endif
diff --git a/libguile/dynl.h b/libguile/dynl.h
deleted file mode 100644
index 723d2e950..000000000
--- a/libguile/dynl.h
+++ /dev/null
@@ -1,57 +0,0 @@
-/* Copyright (C) 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#ifndef LIBGUILE_DYNL_H
-#define LIBGUILE_DYNL_H
-
-#include "libguile/__scm.h"
-
-
-
-SCM scm_dynamic_link SCM_P ((SCM fname));
-SCM scm_dynamic_call SCM_P ((SCM symb, SCM shl));
-SCM scm_dynamic_args_call SCM_P ((SCM symb, SCM shl, SCM args));
-SCM scm_dynamic_unlink SCM_P ((SCM shl));
-
-void scm_init_dynamic_linking SCM_P ((void));
-
-#endif /* LIBGUILE_DYNL_H */
diff --git a/libguile/dynwind.c b/libguile/dynwind.c
deleted file mode 100644
index 4a9424b0f..000000000
--- a/libguile/dynwind.c
+++ /dev/null
@@ -1,139 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "eval.h"
-#include "alist.h"
-
-#include "dynwind.h"
-
-
-/* {Dynamic wind}
- */
-
-
-
-SCM_PROC(s_dynamic_wind, "dynamic-wind", 3, 0, 0, scm_dynamic_wind);
-
-SCM
-scm_dynamic_wind (thunk1, thunk2, thunk3)
- SCM thunk1;
- SCM thunk2;
- SCM thunk3;
-{
- SCM ans;
- scm_apply (thunk1, SCM_EOL, SCM_EOL);
- scm_dynwinds = scm_acons (thunk1, thunk3, scm_dynwinds);
- ans = scm_apply (thunk2, SCM_EOL, SCM_EOL);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- scm_apply (thunk3, SCM_EOL, SCM_EOL);
- return ans;
-}
-
-
-void
-scm_dowinds (to, delta)
- SCM to;
- long delta;
-{
- tail:
- if (scm_dynwinds == to);
- else if (0 > delta)
- {
- SCM wind_elt;
- SCM wind_key;
-
- scm_dowinds (SCM_CDR (to), 1 + delta);
- wind_elt = SCM_CAR (to);
-#if 0
- if (SCM_INUMP (wind_elt))
- {
- scm_cross_dynwind_binding_scope (wind_elt, 0);
- }
- else
-#endif
- {
- wind_key = SCM_CAR (wind_elt);
- if ( !(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key))
- && (wind_key != SCM_BOOL_F)
- && (wind_key != SCM_BOOL_T))
- scm_apply (wind_key, SCM_EOL, SCM_EOL);
- }
- scm_dynwinds = to;
- }
- else
- {
- SCM from;
- SCM wind_elt;
- SCM wind_key;
-
- from = SCM_CDR (SCM_CAR (scm_dynwinds));
- wind_elt = SCM_CAR (scm_dynwinds);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
-#if 0
- if (SCM_INUMP (wind_elt))
- {
- scm_cross_dynwind_binding_scope (wind_elt, 0);
- }
- else
-#endif
- {
- wind_key = SCM_CAR (wind_elt);
- if ( !(SCM_NIMP (wind_key) && SCM_SYMBOLP (wind_key))
- && (wind_key != SCM_BOOL_F)
- && (wind_key != SCM_BOOL_T))
- scm_apply (from, SCM_EOL, SCM_EOL);
- }
- delta--;
- goto tail; /* scm_dowinds(to, delta-1); */
- }
-}
-
-
-
-void
-scm_init_dynwind ()
-{
-#include "dynwind.x"
-}
-
diff --git a/libguile/dynwind.h b/libguile/dynwind.h
deleted file mode 100644
index 7352751c0..000000000
--- a/libguile/dynwind.h
+++ /dev/null
@@ -1,54 +0,0 @@
-/* classes: h_files */
-
-#ifndef DYNWINDH
-#define DYNWINDH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-
-extern SCM scm_dynamic_wind SCM_P ((SCM thunk1, SCM thunk2, SCM thunk3));
-extern void scm_dowinds SCM_P ((SCM to, long delta));
-extern void scm_init_dynwind SCM_P ((void));
-
-#endif /* DYNWINDH */
diff --git a/libguile/eq.c b/libguile/eq.c
deleted file mode 100644
index 5bc88fe75..000000000
--- a/libguile/eq.c
+++ /dev/null
@@ -1,152 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include <stdio.h>
-#include "_scm.h"
-#include "ramap.h"
-#include "stackchk.h"
-#include "strorder.h"
-#include "smob.h"
-#include "unif.h"
-
-#include "eq.h"
-
-SCM_PROC1 (s_eq_p, "eq?", scm_tc7_rpsubr, scm_eq_p);
-
-SCM
-scm_eq_p (x, y)
- SCM x;
- SCM y;
-{
- return ((x==y)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-SCM_PROC1 (s_eqv_p, "eqv?", scm_tc7_rpsubr, scm_eqv_p);
-
-SCM
-scm_eqv_p (x, y)
- SCM x;
- SCM y;
-{
- if (x==y) return SCM_BOOL_T;
- if SCM_IMP(x) return SCM_BOOL_F;
- if SCM_IMP(y) return SCM_BOOL_F;
- /* this ensures that types and scm_length are the same. */
- if (SCM_CAR(x) != SCM_CAR(y)) return SCM_BOOL_F;
- if SCM_NUMP(x) {
-# ifdef SCM_BIGDIG
- if SCM_BIGP(x) return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
-# endif
-#ifdef SCM_FLOATS
- if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F;
- if (SCM_CPLXP(x) && (SCM_IMAG(x) != SCM_IMAG(y))) return SCM_BOOL_F;
-#endif
- return SCM_BOOL_T;
- }
- return SCM_BOOL_F;
-}
-
-
-SCM_PROC1 (s_equal_p, "equal?", scm_tc7_rpsubr, scm_equal_p);
-
-SCM
-scm_equal_p (x, y)
- SCM x;
- SCM y;
-{
- SCM_CHECK_STACK;
- tailrecurse: SCM_ASYNC_TICK;
- if (x==y) return SCM_BOOL_T;
- if (SCM_IMP(x)) return SCM_BOOL_F;
- if (SCM_IMP(y)) return SCM_BOOL_F;
- if (SCM_CONSP(x) && SCM_CONSP(y)) {
- if SCM_FALSEP(scm_equal_p(SCM_CAR(x), SCM_CAR(y))) return SCM_BOOL_F;
- x = SCM_CDR(x);
- y = SCM_CDR(y);
- goto tailrecurse;
- }
- /* this ensures that types and scm_length are the same. */
- if (SCM_CAR(x) != SCM_CAR(y)) return SCM_BOOL_F;
- switch (SCM_TYP7(x)) {
- default: return SCM_BOOL_F;
- case scm_tc7_substring:
- case scm_tc7_mb_substring:
- case scm_tc7_mb_string:
- case scm_tc7_string: return scm_string_equal_p(x, y);
- case scm_tc7_vector:
- case scm_tc7_wvect:
- return scm_vector_equal_p(x, y);
- case scm_tc7_smob: {
- int i = SCM_SMOBNUM(x);
- if (!(i < scm_numsmob)) return SCM_BOOL_F;
- if (scm_smobs[i].equalp)
- return (scm_smobs[i].equalp)(x, y);
- else
- return SCM_BOOL_F;
- }
- case scm_tc7_bvect: case scm_tc7_uvect: case scm_tc7_ivect:
- case scm_tc7_fvect: case scm_tc7_cvect: case scm_tc7_dvect:
- case scm_tc7_svect:
-#ifdef LONGLONGS
- case scm_tc7_llvect:
-#endif
- case scm_tc7_byvect:
- if ( scm_tc16_array
- && scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp)
- return scm_array_equal_p(x, y);
- }
- return SCM_BOOL_F;
-}
-
-
-
-
-
-
-void
-scm_init_eq ()
-{
-#include "eq.x"
-}
-
diff --git a/libguile/eq.h b/libguile/eq.h
deleted file mode 100644
index c9deb5007..000000000
--- a/libguile/eq.h
+++ /dev/null
@@ -1,55 +0,0 @@
-/* classes: h_files */
-
-#ifndef EQH
-#define EQH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-
-extern SCM scm_eq_p SCM_P ((SCM x, SCM y));
-extern SCM scm_eqv_p SCM_P ((SCM x, SCM y));
-extern SCM scm_equal_p SCM_P ((SCM x, SCM y));
-extern void scm_init_eq SCM_P ((void));
-
-#endif /* EQH */
diff --git a/libguile/error.c b/libguile/error.c
deleted file mode 100644
index 68f24a985..000000000
--- a/libguile/error.c
+++ /dev/null
@@ -1,328 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "pairs.h"
-#include "genio.h"
-#include "throw.h"
-
-#include "error.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-
-
-/* {Errors and Exceptional Conditions}
- */
-
-
-/* True between SCM_DEFER_INTS and SCM_ALLOW_INTS, and
- * when the interpreter is not running at all.
- */
-int scm_ints_disabled = 1;
-
-extern int errno;
-
-static void err_head SCM_P ((char *str));
-
-static void
-err_head (str)
- char *str;
-{
- int oerrno = errno;
- if (SCM_NIMP (scm_cur_outp))
- scm_fflush (scm_cur_outp);
- scm_gen_putc ('\n', scm_cur_errp);
-#if 0
- if (SCM_BOOL_F != *scm_loc_loadpath)
- {
- scm_prin1 (*scm_loc_loadpath, scm_cur_errp, 1);
- scm_gen_puts (scm_regular_string, ", line ", scm_cur_errp);
- scm_intprint ((long) scm_linum, 10, scm_cur_errp);
- scm_gen_puts (scm_regular_string, ": ", scm_cur_errp);
- }
-#endif
- scm_fflush (scm_cur_errp);
- errno = oerrno;
- if (scm_cur_errp == scm_def_errp)
- {
- if (errno > 0)
- perror (str);
- fflush (stderr);
- return;
- }
-}
-
-
-SCM_PROC(s_errno, "errno", 0, 1, 0, scm_errno);
-SCM
-scm_errno (arg)
- SCM arg;
-{
- int old = errno;
- if (!SCM_UNBNDP (arg))
- {
- if (SCM_FALSEP (arg))
- errno = 0;
- else
- errno = SCM_INUM (arg);
- }
- return SCM_MAKINUM (old);
-}
-
-SCM_PROC(s_perror, "perror", 1, 0, 0, scm_perror);
-SCM
-scm_perror (arg)
- SCM arg;
-{
- SCM_ASSERT (SCM_NIMP (arg) && SCM_STRINGP (arg), arg, SCM_ARG1, s_perror);
- err_head (SCM_CHARS (arg));
- return SCM_UNSPECIFIED;
-}
-
-void (*scm_error_callback) () = 0;
-
-/* all errors thrown from C should pass through here. */
-void
-scm_error (key, subr, message, args, rest)
- SCM key;
- char *subr;
- char *message;
- SCM args;
- SCM rest;
-{
- SCM arg_list;
- if (scm_error_callback)
- (*scm_error_callback) (key, subr, message, args, rest);
-
- arg_list = scm_listify (subr ? scm_makfrom0str (subr) : SCM_BOOL_F,
- message ? scm_makfrom0str (message) : SCM_BOOL_F,
- args,
- rest,
- SCM_UNDEFINED);
- scm_ithrow (key, arg_list, 1);
-
- /* No return, but just in case: */
-
- write (2, "unhandled system error", sizeof ("unhandled system error") - 1);
- exit (1);
-}
-
-SCM_SYMBOL (scm_system_error_key, "system-error");
-void
-scm_syserror (subr)
- char *subr;
-{
- scm_error (scm_system_error_key,
- subr,
- "%s",
- scm_listify (scm_makfrom0str (strerror (errno)),
- SCM_UNDEFINED),
- scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
-}
-
-void
-scm_syserror_msg (subr, message, args)
- char *subr;
- char *message;
- SCM args;
-{
- scm_error (scm_system_error_key,
- subr,
- message,
- args,
- scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
-}
-
-void
-scm_sysmissing (subr)
- char *subr;
-{
-#ifdef ENOSYS
- scm_error (scm_system_error_key,
- subr,
- "%s",
- scm_listify (scm_makfrom0str (strerror (ENOSYS)), SCM_UNDEFINED),
- scm_listify (SCM_MAKINUM (ENOSYS), SCM_UNDEFINED));
-#else
- scm_error (scm_system_error_key,
- subr,
- "Missing function",
- SCM_BOOL_F,
- scm_listify (SCM_MAKINUM (0), SCM_UNDEFINED));
-#endif
-}
-
-SCM_SYMBOL (scm_num_overflow_key, "numerical-overflow");
-void
-scm_num_overflow (subr)
- char *subr;
-{
- scm_error (scm_num_overflow_key,
- subr,
- "Numerical overflow",
- SCM_BOOL_F,
- SCM_BOOL_F);
-}
-
-SCM_SYMBOL (scm_out_of_range_key, "out-of-range");
-void
-scm_out_of_range (subr, bad_value)
- char *subr;
- SCM bad_value;
-{
- scm_error (scm_out_of_range_key,
- subr,
- "Argument out of range: %S",
- scm_listify (bad_value, SCM_UNDEFINED),
- SCM_BOOL_F);
-}
-
-SCM_SYMBOL (scm_args_number_key, "wrong-number-of-args");
-void
-scm_wrong_num_args (proc)
- SCM proc;
-{
- scm_error (scm_args_number_key,
- NULL,
- "Wrong number of arguments to %s",
- scm_listify (proc, SCM_UNDEFINED),
- SCM_BOOL_F);
-}
-
-SCM_SYMBOL (scm_arg_type_key, "wrong-type-arg");
-void
-scm_wrong_type_arg (subr, pos, bad_value)
- char *subr;
- int pos;
- SCM bad_value;
-{
- scm_error (scm_arg_type_key,
- subr,
- (pos == 0) ? "Wrong type argument: %S"
- : "Wrong type argument in position %s: %S",
- (pos == 0) ? scm_listify (bad_value, SCM_UNDEFINED)
- : scm_listify (SCM_MAKINUM (pos), bad_value, SCM_UNDEFINED),
- SCM_BOOL_F);
-}
-
-SCM_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
-void
-scm_memory_error (subr)
- char *subr;
-{
- scm_error (scm_memory_alloc_key,
- subr,
- "Memory allocation error",
- SCM_BOOL_F,
- SCM_BOOL_F);
-}
-
-SCM_SYMBOL (scm_misc_error_key, "misc-error");
-void
-scm_misc_error (subr, message, args)
- char *subr;
- char *message;
- SCM args;
-{
- scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
-}
-
-/* implements the SCM_ASSERT interface. */
-SCM
-scm_wta (arg, pos, s_subr)
- SCM arg;
- char *pos;
- char *s_subr;
-{
- if (!s_subr || !*s_subr)
- s_subr = NULL;
- if ((~0x1fL) & (long) pos)
- {
- /* error string supplied. */
- scm_misc_error (s_subr, pos, SCM_BOOL_F);
- }
- else
- {
- /* numerical error code. */
- int error = (long) pos;
-
- switch (error)
- {
- case SCM_ARGn:
- scm_wrong_type_arg (s_subr, 0, arg);
- case SCM_ARG1:
- scm_wrong_type_arg (s_subr, 1, arg);
- case SCM_ARG2:
- scm_wrong_type_arg (s_subr, 2, arg);
- case SCM_ARG3:
- scm_wrong_type_arg (s_subr, 3, arg);
- case SCM_ARG4:
- scm_wrong_type_arg (s_subr, 4, arg);
- case SCM_ARG5:
- scm_wrong_type_arg (s_subr, 5, arg);
- case SCM_WNA:
- scm_wrong_num_args (arg);
- case SCM_OUTOFRANGE:
- scm_out_of_range (s_subr, arg);
- case SCM_NALLOC:
- scm_memory_error (s_subr);
- default:
- /* this shouldn't happen. */
- scm_misc_error (s_subr, "Unknown error", SCM_BOOL_F);
- }
- }
- return SCM_UNSPECIFIED;
-}
-
-/* obsolete interface: scm_everr (exp, env, arg, pos, s_subr)
- was equivalent to scm_wta (arg, pos, s_subr) */
-
-void
-scm_init_error ()
-{
-#include "error.x"
-}
-
diff --git a/libguile/error.h b/libguile/error.h
deleted file mode 100644
index 0ce16289a..000000000
--- a/libguile/error.h
+++ /dev/null
@@ -1,84 +0,0 @@
-/* classes: h_files */
-
-#ifndef ERRORH
-#define ERRORH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-extern int scm_ints_disabled;
-
-
-
-/* GCC can be told that a function doesn't return; this helps it do
- better error checking (for uninitialized variable use, for
- example), and some optimization. */
-#ifdef __GNUC__
-#define SCM_NORETURN __attribute__ ((noreturn))
-#else
-#define SCM_NORETURN
-#endif
-
-
-extern SCM scm_errno SCM_P ((SCM arg));
-extern SCM scm_perror SCM_P ((SCM arg));
-extern void scm_error SCM_P ((SCM key, char *subr, char *message,
- SCM args, SCM rest)) SCM_NORETURN;
-extern void (*scm_error_callback) SCM_P ((SCM key, char *subr,
- char *message, SCM args, SCM rest));
-extern void scm_syserror SCM_P ((char *subr)) SCM_NORETURN;
-extern void scm_syserror_msg SCM_P ((char *subr, char *message, SCM args))
- SCM_NORETURN;
-extern void scm_sysmissing SCM_P ((char *subr)) SCM_NORETURN;
-extern void scm_num_overflow SCM_P ((char *subr)) SCM_NORETURN;
-extern void scm_out_of_range SCM_P ((char *subr, SCM bad_value)) SCM_NORETURN;
-extern void scm_wrong_num_args SCM_P ((SCM proc)) SCM_NORETURN;
-extern void scm_wrong_type_arg SCM_P ((char *subr, int pos, SCM bad_value))
- SCM_NORETURN;
-extern void scm_memory_error SCM_P ((char *subr)) SCM_NORETURN;
-extern void scm_misc_error SCM_P ((char *subr, char *message, SCM args))
- SCM_NORETURN;
-extern SCM scm_wta SCM_P ((SCM arg, char *pos, char *s_subr));
-extern void scm_init_error SCM_P ((void));
-
-#endif /* ERRORH */
diff --git a/libguile/eval.h b/libguile/eval.h
deleted file mode 100644
index f83eb1560..000000000
--- a/libguile/eval.h
+++ /dev/null
@@ -1,170 +0,0 @@
-/* classes: h_files */
-
-#ifndef EVALH
-#define EVALH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-/* {Ilocs}
- *
- * Ilocs are relative pointers into local environment structures.
- *
- */
-#define SCM_ILOCP(n) (SCM_ITAG8(n)==scm_tc8_iloc)
-#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
-#define SCM_IDINC (0x00100000L)
-#define SCM_ICDR (0x00080000L)
-#define SCM_IFRINC (0x00000100L)
-#define SCM_IDSTMSK (-SCM_IDINC)
-#define SCM_IFRAME(n) ((int)((SCM_ICDR-SCM_IFRINC)>>8) & ((int)(n)>>8))
-#define SCM_IDIST(n) (((unsigned long)(n))>>20)
-#define SCM_ICDRP(n) (SCM_ICDR & (n))
-
-
-
-
-/* {Evaluator}
- *
- * For an explanation of symbols containing "EVAL", see beginning of eval.c.
- */
-#ifdef DEBUG_EXTENSIONS
-#define XEVAL(x, env) (SCM_IMP(x) \
- ? (x) \
- : (*scm_ceval_ptr) ((x), (env)))
-#else
-#define XEVAL(x, env) (SCM_IMP(x)?(x):scm_ceval((x), (env)))
-#endif /* DEBUG_EXTENSIONS */
-
-#define SCM_CEVAL scm_ceval
-#define SIDEVAL(x, env) if SCM_NIMP(x) SCM_CEVAL((x), (env))
-
-
-
-#define SCM_EXTEND_ENV scm_acons
-
-
-extern SCM scm_i_dot;
-extern SCM scm_i_quote;
-extern SCM scm_i_quasiquote;
-extern SCM scm_i_lambda;
-extern SCM scm_i_let;
-extern SCM scm_i_arrow;
-extern SCM scm_i_else;
-extern SCM scm_i_unquote;
-extern SCM scm_i_uq_splicing;
-extern SCM scm_i_apply;
-
-
-/* A resolved global variable reference in the CAR position
- * of a list is stored (in code only) as a pointer to a pair with a
- * tag of 1. This is called a "gloc".
- */
-
-#define SCM_GLOC_SYM(x) (SCM_CAR((x)-1L))
-#define SCM_GLOC_VAL(x) (SCM_CDR((x)-1L))
-#define SCM_GLOC_VAL_LOC(x) (SCM_CDRLOC((x)-1L))
-
-
-
-extern SCM * scm_ilookup SCM_P ((SCM iloc, SCM env));
-extern SCM * scm_lookupcar SCM_P ((SCM vloc, SCM genv));
-extern SCM scm_unmemocar SCM_P ((SCM form, SCM env));
-extern SCM scm_unmemocopy SCM_P ((SCM form, SCM env));
-extern SCM scm_eval_car SCM_P ((SCM pair, SCM env));
-extern SCM scm_eval_args SCM_P ((SCM i, SCM env));
-extern SCM scm_deval_args SCM_P ((SCM l, SCM env, SCM *lloc));
-extern SCM scm_m_quote SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_begin SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_if SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_set SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_vref SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_vset SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_and SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_or SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_case SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_cond SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_lambda SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_letstar SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_do SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_quasiquote SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_delay SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_define SCM_P ((SCM x, SCM env));
-extern SCM scm_m_letrec SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_let SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_apply SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_cont SCM_P ((SCM xorig, SCM env));
-extern SCM scm_m_undefine SCM_P ((SCM x, SCM env));
-extern int scm_badargsp SCM_P ((SCM formals, SCM args));
-extern SCM scm_ceval SCM_P ((SCM x, SCM env));
-extern SCM scm_deval SCM_P ((SCM x, SCM env));
-extern SCM scm_procedure_documentation SCM_P ((SCM proc));
-extern SCM scm_nconc2last SCM_P ((SCM lst));
-extern SCM scm_apply SCM_P ((SCM proc, SCM arg1, SCM args));
-extern SCM scm_dapply SCM_P ((SCM proc, SCM arg1, SCM args));
-extern SCM SCM_APPLY SCM_P ((SCM proc, SCM arg1, SCM args));
-extern SCM scm_map SCM_P ((SCM proc, SCM arg1, SCM args));
-extern SCM scm_for_each SCM_P ((SCM proc, SCM arg1, SCM args));
-extern SCM scm_closure SCM_P ((SCM code, SCM env));
-extern SCM scm_makprom SCM_P ((SCM code));
-extern SCM scm_makacro SCM_P ((SCM code));
-extern SCM scm_makmacro SCM_P ((SCM code));
-extern SCM scm_makmmacro SCM_P ((SCM code));
-extern SCM scm_force SCM_P ((SCM x));
-extern SCM scm_promise_p SCM_P ((SCM x));
-extern SCM scm_copy_tree SCM_P ((SCM obj));
-extern SCM scm_eval_3 SCM_P ((SCM obj, int copyp, SCM env));
-extern SCM scm_top_level_env SCM_P ((SCM thunk));
-extern SCM scm_eval2 SCM_P ((SCM obj, SCM env_thunk));
-extern SCM scm_eval SCM_P ((SCM obj));
-extern SCM scm_eval_x SCM_P ((SCM obj));
-extern SCM scm_macro_eval_x SCM_P ((SCM exp, SCM env));
-extern SCM scm_definedp SCM_P ((SCM sym));
-extern SCM scm_make_synt SCM_P ((char *name,
- SCM (*macroizer) (SCM),
- SCM (*fcn) ()));
-extern void scm_init_eval SCM_P ((void));
-
-#endif /* EVALH */
diff --git a/libguile/extchrs.c b/libguile/extchrs.c
deleted file mode 100644
index 6b063da8a..000000000
--- a/libguile/extchrs.c
+++ /dev/null
@@ -1,134 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "extchrs.h"
-
-
-
-#ifdef SCM_FAKE_EXT_CHARS
-
-
-int
-xmblen (str, size)
- const char * str;
- size_t size;
-{
- if (!str)
- return 0;
-
- if (*(unsigned char *)str > 127)
- return ((size < 4)
- ? -1
- : 4);
- else if (!*str)
- return 0;
- else
- return 1;
-}
-
-
-int
-xwctomb (_str, c)
- char * _str;
- int c;
-{
- unsigned char * str;
- str = (unsigned char *)_str;
- if (!str)
- return 0;
-
- if (!c)
- {
- *str = 0;
- return 0;
- }
-
-
- if (c < 127)
- {
- *str = c;
- return 1;
- }
-
- str[0] = 255;
- str[1] = 0x80 | ((c >> 10) & 0x3f);
- str[2] = 0x80 | ((c >> 4) & 0x3f);
- str[3] = 0x80 | (c & 0xf);
- return 4;
-}
-
-
-int
-xmbtowc (result, _str, size)
- xwchar_t * result;
- const unsigned char * _str;
- size_t size;
-{
- const unsigned char * str;
- str = (const unsigned char *)_str;
- if (!str)
- return 0;
-
- if ((size == 0) || !*str)
- {
- *result = 0;
- return 0;
- }
-
- if (*str < 128)
- {
- *result = *str;
- return 1;
- }
-
- if ( (*str != 255)
- || (size < 4))
- return -1;
-
- *result = ( ((str[1] & 0x3f) << 10)
- | ((str[2] & 0x3f) << 4)
- | (str[3] & 0xf));
- return 4;
-}
-
-#endif /* SCM_FAKE_EXT_CHARS */
-
diff --git a/libguile/extchrs.h b/libguile/extchrs.h
deleted file mode 100644
index 3f1f02276..000000000
--- a/libguile/extchrs.h
+++ /dev/null
@@ -1,74 +0,0 @@
-/* classes: h_files */
-
-#ifndef EXTCHRSH
-#define EXTCHRSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdlib.h>
-
-#include "libguile/__scm.h"
-
-#define SCM_FAKE_EXT_CHARS 1
-
-#if !defined(SCM_FAKE_EXT_CHARS)
-
-#define xmblen mblen
-#define xwctomb wctomb
-#define xmbtowc mbtowc
-#define XMB_CUR_MAX MB_CUR_MAX
-typedef wchar_t xwchar_t;
-
-#else
-
-typedef unsigned short xwchar_t;
-#define XMB_CUR_MAX 4
-
-#endif
-
-
-
-extern int xmblen SCM_P ((const char * str, size_t size));
-extern int xwctomb SCM_P ((char * _str, int c));
-extern int xmbtowc SCM_P ((xwchar_t * result, const unsigned char * _str, size_t size));
-
-#endif /* EXTCHRSH */
diff --git a/libguile/feature.c b/libguile/feature.c
deleted file mode 100644
index 9aaee678c..000000000
--- a/libguile/feature.c
+++ /dev/null
@@ -1,121 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-
-#include "feature.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-
-static SCM *scm_loc_features;
-
-void
-scm_add_feature(str)
- char* str;
-{
- *scm_loc_features = scm_cons(SCM_CAR(scm_intern(str, strlen(str))),
- *scm_loc_features);
-}
-
-
-
-SCM_PROC(s_program_arguments, "program-arguments", 0, 0, 0, scm_program_arguments);
-
-SCM
-scm_program_arguments ()
-{
- return scm_progargs;
-}
-
-/* Set the value returned by program-arguments, given ARGC and ARGV.
-
- If FIRST is non-zero, make it the first element; we do this in
- situations where other code (like getopt) has parsed out a few
- arguments, but we still want the script name to be the first
- element. */
-void
-scm_set_program_arguments (argc, argv, first)
- int argc;
- char **argv;
- char *first;
-{
- scm_progargs = scm_makfromstrs (argc, argv);
- if (first)
- scm_progargs = scm_cons (scm_makfrom0str (first), scm_progargs);
-}
-
-
-
-
-void
-scm_init_feature()
-{
- scm_loc_features = SCM_CDRLOC (scm_sysintern ("*features*", SCM_EOL));
-#ifdef RECKLESS
- scm_add_feature("reckless");
-#endif
-#ifndef _Windows
- scm_add_feature("system");
-#endif
-#ifdef vms
- scm_add_feature(s_ed);
-#endif
-#ifdef SICP
- scm_add_feature("sicp");
-#endif
-#ifndef GO32
- scm_add_feature("char-ready?");
-#endif
-#ifndef CHEAP_CONTINUATIONS
- scm_add_feature ("full-continuation");
-#endif
-#ifdef USE_THREADS
- scm_add_feature ("threads");
-#endif
-
- scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT));
-#include "feature.x"
-}
diff --git a/libguile/feature.h b/libguile/feature.h
deleted file mode 100644
index 712aff8a0..000000000
--- a/libguile/feature.h
+++ /dev/null
@@ -1,55 +0,0 @@
-/* classes: h_files */
-
-#ifndef FEATUREH
-#define FEATUREH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-extern void scm_add_feature SCM_P((char* str));
-extern SCM scm_program_arguments SCM_P((void));
-extern void scm_set_program_arguments SCM_P ((int argc, char **argv,
- char *first));
-extern void scm_init_feature SCM_P((void));
-
-#endif /* FEATUREH */
diff --git a/libguile/filesys.c b/libguile/filesys.c
deleted file mode 100644
index 38f0b7768..000000000
--- a/libguile/filesys.c
+++ /dev/null
@@ -1,1311 +0,0 @@
-/* Copyright (C) 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "_scm.h"
-#include "genio.h"
-#include "smob.h"
-#include "feature.h"
-
-#include "filesys.h"
-
-#ifdef TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-#else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef LIBC_H_WITH_UNISTD_H
-#include <libc.h>
-#endif
-
-#ifdef HAVE_SYS_SELECT_H
-#include <sys/select.h>
-#endif
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <fcntl.h>
-
-#include <pwd.h>
-
-
-#ifdef FD_SET
-
-#define SELECT_TYPE fd_set
-#define SELECT_SET_SIZE FD_SETSIZE
-
-#else /* no FD_SET */
-
-/* Define the macros to access a single-int bitmap of descriptors. */
-#define SELECT_SET_SIZE 32
-#define SELECT_TYPE int
-#define FD_SET(n, p) (*(p) |= (1 << (n)))
-#define FD_CLR(n, p) (*(p) &= ~(1 << (n)))
-#define FD_ISSET(n, p) (*(p) & (1 << (n)))
-#define FD_ZERO(p) (*(p) = 0)
-
-#endif /* no FD_SET */
-
-#if HAVE_DIRENT_H
-# include <dirent.h>
-# define NAMLEN(dirent) strlen((dirent)->d_name)
-#else
-# define dirent direct
-# define NAMLEN(dirent) (dirent)->d_namlen
-# if HAVE_SYS_NDIR_H
-# include <sys/ndir.h>
-# endif
-# if HAVE_SYS_DIR_H
-# include <sys/dir.h>
-# endif
-# if HAVE_NDIR_H
-# include <ndir.h>
-# endif
-#endif
-
-
-
-#ifdef O_CREAT
-SCM_CONST_LONG (scm_O_CREAT, "O_CREAT", O_CREAT);
-#endif
-
-#ifdef O_EXCL
-SCM_CONST_LONG (scm_O_EXCL, "O_EXCL", O_EXCL);
-#endif
-
-#ifdef O_NOCTTY
-SCM_CONST_LONG (scm_O_NOCTTY, "O_NOCTTY", O_NOCTTY);
-#endif
-
-#ifdef O_TRUNC
-SCM_CONST_LONG (scm_O_TRUNC, "O_TRUNC", O_TRUNC);
-#endif
-
-#ifdef O_APPEND
-SCM_CONST_LONG (scm_O_APPEND, "O_APPEND", O_APPEND);
-#endif
-
-#ifdef O_NONBLOCK
-SCM_CONST_LONG (scm_O_NONBLOCK, "O_NONBLOCK", O_NONBLOCK);
-#endif
-
-#ifdef O_NDELAY
-SCM_CONST_LONG (scm_O_NDELAY, "O_NDELAY", O_NDELAY);
-#endif
-
-#ifdef O_SYNC
-SCM_CONST_LONG (scm_O_SYNC, "O_SYNC", O_SYNC);
-#endif
-
-
-
-
-
-/* {Permissions}
- */
-
-SCM_PROC (s_sys_chown, "chown", 3, 0, 0, scm_sys_chown);
-
-SCM
-scm_sys_chown (path, owner, group)
- SCM path;
- SCM owner;
- SCM group;
-{
- int val;
-
- SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_chown);
- if (SCM_SUBSTRP (path))
- path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
- SCM_ASSERT (SCM_INUMP (owner), owner, SCM_ARG2, s_sys_chown);
- SCM_ASSERT (SCM_INUMP (group), group, SCM_ARG3, s_sys_chown);
- SCM_SYSCALL (val = chown (SCM_ROCHARS (path),
- SCM_INUM (owner), SCM_INUM (group)));
- if (val != 0)
- scm_syserror (s_sys_chown);
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC (s_sys_chmod, "chmod", 2, 0, 0, scm_sys_chmod);
-
-SCM
-scm_sys_chmod (port_or_path, mode)
- SCM port_or_path;
- SCM mode;
-{
- int rv;
- SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_chmod);
- SCM_ASSERT (SCM_NIMP (port_or_path), port_or_path, SCM_ARG1, s_sys_chmod);
- if (SCM_STRINGP (port_or_path))
- SCM_SYSCALL (rv = chmod (SCM_CHARS (port_or_path), SCM_INUM (mode)));
- else
- {
- SCM_ASSERT (SCM_OPFPORTP (port_or_path), port_or_path, SCM_ARG1, s_sys_chmod);
- rv = fileno ((FILE *)SCM_STREAM (port_or_path));
- if (rv != -1)
- SCM_SYSCALL (rv = fchmod (rv, SCM_INUM (mode)));
- }
- if (rv != 0)
- scm_syserror (s_sys_chmod);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_umask, "umask", 0, 1, 0, scm_umask);
-
-SCM
-scm_umask (mode)
- SCM mode;
-{
- mode_t mask;
- if (SCM_UNBNDP (mode))
- {
- mask = umask (0);
- umask (mask);
- }
- else
- {
- SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG1, s_umask);
- mask = umask (SCM_INUM (mode));
- }
- return SCM_MAKINUM (mask);
-}
-
-
-/* {File Descriptors}
- */
-long scm_tc16_fd;
-
-
-static int scm_fd_print SCM_P ((SCM sexp, SCM port, scm_print_state *pstate));
-
-static int
-scm_fd_print (sexp, port, pstate)
- SCM sexp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_gen_puts (scm_regular_string, "#<fd ", port);
- scm_intprint (SCM_CDR (sexp), 10, port);
- scm_gen_puts (scm_regular_string, ">", port);
- return 1;
-}
-
-
-static scm_sizet scm_fd_free SCM_P ((SCM p));
-
-static scm_sizet
-scm_fd_free (p)
- SCM p;
-{
- SCM flags;
-
- flags = SCM_FD_FLAGS (p);
- if ((scm_close_fd_on_gc & flags) && (scm_fd_is_open & flags))
- {
- SCM_SYSCALL( close (SCM_FD (p)) );
- }
- return 0;
-}
-
-static scm_smobfuns fd_smob = {scm_mark0, scm_fd_free, scm_fd_print, 0};
-
-
-SCM
-scm_intern_fd (fd, flags)
- int fd;
- int flags;
-{
- SCM it;
- SCM_NEWCELL (it);
- SCM_REDEFER_INTS;
- SCM_SETCAR (it, (scm_tc16_fd | (flags << 16)));
- SCM_SETCDR (it, (SCM)fd);
- SCM_REALLOW_INTS;
- return it;
-}
-
-
-
-SCM_PROC (s_sys_open, "open", 3, 0, 0, scm_sys_open);
-
-SCM
-scm_sys_open (path, flags, mode)
- SCM path;
- SCM flags;
- SCM mode;
-{
- int fd;
- SCM sfd;
-
- SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_open);
- SCM_ASSERT (SCM_INUMP (flags), flags, SCM_ARG2, s_sys_open);
- SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG3, s_sys_open);
-
- if (SCM_SUBSTRP (path))
- path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
-
- SCM_DEFER_INTS;
- SCM_SYSCALL ( fd = open (SCM_ROCHARS (path), SCM_INUM (flags), SCM_INUM (mode)) );
- if (fd == -1)
- scm_syserror (s_sys_open);
- sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc);
- SCM_ALLOW_INTS;
-
- return scm_return_first (sfd, path);
-}
-
-
-SCM_PROC (s_sys_create, "create", 2, 0, 0, scm_sys_create);
-
-SCM
-scm_sys_create (path, mode)
- SCM path;
- SCM mode;
-{
- int fd;
- SCM sfd;
-
- SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_sys_create);
- SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_create);
-
- if (SCM_SUBSTRP (path))
- path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
-
- SCM_DEFER_INTS;
- SCM_SYSCALL ( fd = creat (SCM_ROCHARS (path), SCM_INUM (mode)) );
- if (fd == -1)
- scm_syserror (s_sys_create);
- sfd = scm_intern_fd (fd, scm_fd_is_open | scm_close_fd_on_gc);
- SCM_ALLOW_INTS;
-
- return scm_return_first (sfd, path);
-}
-
-
-SCM_PROC (s_sys_close, "close", 1, 0, 0, scm_sys_close);
-
-SCM
-scm_sys_close (sfd)
- SCM sfd;
-{
- int fd;
- int got;
- SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_close);
- fd = SCM_FD (sfd);
-
- SCM_DEFER_INTS;
- got = close (fd);
- SCM_SETCAR (sfd, scm_tc16_fd);
- SCM_ALLOW_INTS;
- if (got == -1)
- scm_syserror (s_sys_close);
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC (s_sys_write_fd, "write-fd", 2, 0, 0, scm_sys_write_fd);
-
-SCM
-scm_sys_write_fd (sfd, buf)
- SCM sfd;
- SCM buf;
-{
- SCM answer;
- int fd;
- size_t written;
- SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_write_fd);
- SCM_ASSERT (SCM_NIMP (buf) && SCM_ROSTRINGP (buf), buf, SCM_ARG2, s_sys_write_fd);
- fd = SCM_FD (sfd);
- SCM_DEFER_INTS;
- written = write (fd, SCM_ROCHARS (buf), SCM_ROLENGTH (buf));
- if (written == -1)
- scm_syserror (s_sys_write_fd);
- answer = scm_long2num (written);
- SCM_ALLOW_INTS;
- return scm_return_first (answer, buf);
-}
-
-
-SCM_PROC (s_sys_read_fd, "read-fd", 2, 2, 0, scm_sys_read_fd);
-
-SCM
-scm_sys_read_fd (sfd, buf, offset, length)
- SCM sfd;
- SCM buf;
- SCM offset;
- SCM length;
-{
- SCM answer;
- int fd;
- char * bytes;
- int off;
- int len;
- size_t got;
-
- SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_read_fd);
- fd = SCM_FD (sfd);
-
- SCM_ASSERT (SCM_NIMP (buf) && SCM_STRINGP (buf), buf, SCM_ARG2, s_sys_read_fd);
- bytes = SCM_CHARS (buf);
-
- if (SCM_UNBNDP (offset))
- off = 0;
- else
- {
- SCM_ASSERT (SCM_INUMP (offset), offset, SCM_ARG3, s_sys_read_fd);
- off = SCM_INUM (offset);
- }
-
- if (SCM_UNBNDP (length))
- len = SCM_LENGTH (buf);
- else
- {
- SCM_ASSERT (SCM_INUMP (length), length, SCM_ARG3, s_sys_read_fd);
- len = SCM_INUM (length);
- }
-
- SCM_DEFER_INTS;
- got = read (fd, bytes + off, len);
- if (got == -1)
- scm_syserror (s_sys_read_fd);
- answer = scm_long2num (got);
- SCM_ALLOW_INTS;
- return scm_return_first (answer, buf);
-}
-
-SCM_PROC (s_sys_lseek, "lseek", 2, 1, 0, scm_sys_lseek);
-
-SCM
-scm_sys_lseek (sfd, offset, whence)
- SCM sfd;
- SCM offset;
- SCM whence;
-{
- SCM answer;
- int fd;
- long off;
- int wh;
- long got;
-
- SCM_ASSERT (SCM_NIMP (sfd) && SCM_FD_P (sfd), sfd, SCM_ARG1, s_sys_lseek);
- fd = SCM_FD (sfd);
-
- off = scm_num2long (offset, (char *)SCM_ARG2, s_sys_lseek);
- if (SCM_UNBNDP (whence))
- wh = SEEK_SET;
- else
- {
- SCM_ASSERT (SCM_INUMP (whence), whence, SCM_ARG3, s_sys_lseek);
- wh = SCM_INUM (whence);
- }
-
- SCM_DEFER_INTS;
- SCM_SYSCALL (got = lseek (fd, off, wh));
- if (got == -1)
- scm_syserror (s_sys_lseek);
- answer = scm_long2num (got);
- SCM_ALLOW_INTS;
- return answer;
-}
-
-
-SCM_PROC (s_sys_dup, "dup", 1, 1, 0, scm_sys_dup);
-
-SCM
-scm_sys_dup (oldfd, newfd)
- SCM oldfd;
- SCM newfd;
-{
- SCM answer;
- int fd;
- int nfd;
- int (*fn)();
-
- SCM_ASSERT (SCM_NIMP (oldfd) && SCM_FD_P (oldfd), oldfd, SCM_ARG1, s_sys_dup);
- SCM_ASSERT (SCM_UNBNDP (newfd) || SCM_INUMP (newfd), newfd, SCM_ARG2, s_sys_dup);
- fd = SCM_FD (oldfd);
- nfd = (SCM_INUMP (newfd) ? SCM_INUM (newfd) : -1);
-
- SCM_DEFER_INTS;
- fn = ((nfd == -1) ? (int (*)())dup : (int (*)())dup2);
- nfd = fn (fd, nfd);
- if (nfd == -1)
- scm_syserror (s_sys_dup);
- answer = SCM_MAKINUM (nfd);
- SCM_ALLOW_INTS;
- return answer;
-}
-
-
-
-/* {Files}
- */
-
-SCM_SYMBOL (scm_sym_regular, "regular");
-SCM_SYMBOL (scm_sym_directory, "directory");
-SCM_SYMBOL (scm_sym_symlink, "symlink");
-SCM_SYMBOL (scm_sym_block_special, "block-special");
-SCM_SYMBOL (scm_sym_char_special, "char-special");
-SCM_SYMBOL (scm_sym_fifo, "fifo");
-SCM_SYMBOL (scm_sym_sock, "socket");
-SCM_SYMBOL (scm_sym_unknown, "unknown");
-
-static SCM scm_stat2scm SCM_P ((struct stat *stat_temp));
-
-static SCM
-scm_stat2scm (stat_temp)
- struct stat *stat_temp;
-{
- SCM ans = scm_make_vector (SCM_MAKINUM (15), SCM_UNSPECIFIED, SCM_BOOL_F);
- SCM *ve = SCM_VELTS (ans);
-
- ve[0] = scm_ulong2num ((unsigned long) stat_temp->st_dev);
- ve[1] = scm_ulong2num ((unsigned long) stat_temp->st_ino);
- ve[2] = scm_ulong2num ((unsigned long) stat_temp->st_mode);
- ve[3] = scm_ulong2num ((unsigned long) stat_temp->st_nlink);
- ve[4] = scm_ulong2num ((unsigned long) stat_temp->st_uid);
- ve[5] = scm_ulong2num ((unsigned long) stat_temp->st_gid);
-#ifdef HAVE_ST_RDEV
- ve[6] = scm_ulong2num ((unsigned long) stat_temp->st_rdev);
-#else
- ve[6] = SCM_BOOL_F;
-#endif
- ve[7] = scm_ulong2num ((unsigned long) stat_temp->st_size);
- ve[8] = scm_ulong2num ((unsigned long) stat_temp->st_atime);
- ve[9] = scm_ulong2num ((unsigned long) stat_temp->st_mtime);
- ve[10] = scm_ulong2num ((unsigned long) stat_temp->st_ctime);
-#ifdef HAVE_ST_BLKSIZE
- ve[11] = scm_ulong2num ((unsigned long) stat_temp->st_blksize);
-#else
- ve[11] = scm_ulong2num (4096L);
-#endif
-#ifdef HAVE_ST_BLOCKS
- ve[12] = scm_ulong2num ((unsigned long) stat_temp->st_blocks);
-#else
- ve[12] = SCM_BOOL_F;
-#endif
- {
- int mode = stat_temp->st_mode;
-
- if (S_ISREG (mode))
- ve[13] = scm_sym_regular;
- else if (S_ISDIR (mode))
- ve[13] = scm_sym_directory;
- else if (S_ISLNK (mode))
- ve[13] = scm_sym_symlink;
- else if (S_ISBLK (mode))
- ve[13] = scm_sym_block_special;
- else if (S_ISCHR (mode))
- ve[13] = scm_sym_char_special;
- else if (S_ISFIFO (mode))
- ve[13] = scm_sym_fifo;
- else if (S_ISSOCK (mode))
- ve[13] = scm_sym_sock;
- else
- ve[13] = scm_sym_unknown;
-
- ve[14] = SCM_MAKINUM ((~S_IFMT) & mode);
-
- /* the layout of the bits in ve[14] is intended to be portable.
- If there are systems that don't follow the usual convention,
- the following could be used:
-
- tmp = 0;
- if (S_ISUID & mode) tmp += 1;
- tmp <<= 1;
- if (S_IRGRP & mode) tmp += 1;
- tmp <<= 1;
- if (S_ISVTX & mode) tmp += 1;
- tmp <<= 1;
- if (S_IRUSR & mode) tmp += 1;
- tmp <<= 1;
- if (S_IWUSR & mode) tmp += 1;
- tmp <<= 1;
- if (S_IXUSR & mode) tmp += 1;
- tmp <<= 1;
- if (S_IWGRP & mode) tmp += 1;
- tmp <<= 1;
- if (S_IXGRP & mode) tmp += 1;
- tmp <<= 1;
- if (S_IROTH & mode) tmp += 1;
- tmp <<= 1;
- if (S_IWOTH & mode) tmp += 1;
- tmp <<= 1;
- if (S_IXOTH & mode) tmp += 1;
-
- ve[14] = SCM_MAKINUM (tmp);
-
- */
- }
-
- return ans;
-}
-
-SCM_PROC (s_sys_stat, "stat", 1, 0, 0, scm_sys_stat);
-
-SCM
-scm_sys_stat (fd_or_path)
- SCM fd_or_path;
-{
- int rv = 1;
- struct stat stat_temp;
-
- if (SCM_INUMP (fd_or_path))
- {
- rv = SCM_INUM (fd_or_path);
- SCM_SYSCALL (rv = fstat (rv, &stat_temp));
- }
- else if (SCM_NIMP (fd_or_path) && SCM_FD_P (fd_or_path))
- {
- rv = SCM_FD (fd_or_path);
- SCM_SYSCALL (rv = fstat (rv, &stat_temp));
- }
- else
- {
- SCM_ASSERT (SCM_NIMP (fd_or_path), fd_or_path, SCM_ARG1, s_sys_stat);
- SCM_ASSERT (SCM_ROSTRINGP (fd_or_path), fd_or_path, SCM_ARG1, s_sys_stat);
- if (SCM_ROSTRINGP (fd_or_path))
- {
- if (SCM_SUBSTRP (fd_or_path))
- fd_or_path = scm_makfromstr (SCM_ROCHARS (fd_or_path), SCM_ROLENGTH (fd_or_path), 0);
- SCM_SYSCALL (rv = stat (SCM_CHARS (fd_or_path), &stat_temp));
- }
-
- }
- if (rv != 0)
- scm_syserror_msg (s_sys_stat, "%s: %S",
- scm_listify (scm_makfrom0str (strerror (errno)),
- fd_or_path,
- SCM_UNDEFINED));
- return scm_stat2scm (&stat_temp);
-}
-
-
-
-/* {Modifying Directories}
- */
-
-SCM_PROC (s_sys_link, "link", 2, 0, 0, scm_sys_link);
-
-SCM
-scm_sys_link (oldpath, newpath)
- SCM oldpath;
- SCM newpath;
-{
- int val;
-
- SCM_ASSERT (SCM_NIMP (oldpath) && SCM_ROSTRINGP (oldpath), oldpath, SCM_ARG1, s_sys_link);
- if (SCM_SUBSTRP (oldpath))
- oldpath = scm_makfromstr (SCM_ROCHARS (oldpath), SCM_ROLENGTH (oldpath), 0);
- SCM_ASSERT (SCM_NIMP (newpath) && SCM_ROSTRINGP (newpath), newpath, SCM_ARG2, s_sys_link);
- if (SCM_SUBSTRP (newpath))
- newpath = scm_makfromstr (SCM_ROCHARS (newpath), SCM_ROLENGTH (newpath), 0);
- SCM_SYSCALL (val = link (SCM_ROCHARS (oldpath), SCM_ROCHARS (newpath)));
- if (val != 0)
- scm_syserror (s_sys_link);
- return SCM_UNSPECIFIED;
-}
-
-
-
-SCM_PROC (s_sys_rename, "rename-file", 2, 0, 0, scm_sys_rename);
-
-SCM
-scm_sys_rename (oldname, newname)
- SCM oldname;
- SCM newname;
-{
- int rv;
- SCM_ASSERT (SCM_NIMP (oldname) && SCM_STRINGP (oldname), oldname, SCM_ARG1, s_sys_rename);
- SCM_ASSERT (SCM_NIMP (newname) && SCM_STRINGP (newname), newname, SCM_ARG2, s_sys_rename);
-#ifdef HAVE_RENAME
- SCM_SYSCALL (rv = rename (SCM_CHARS (oldname), SCM_CHARS (newname)));
- if (rv != 0)
- scm_syserror (s_sys_rename);
- return SCM_UNSPECIFIED;
-#else
- SCM_DEFER_INTS;
- SCM_SYSCALL (rv = link (SCM_CHARS (oldname), SCM_CHARS (newname)));
- if (rv == 0)
- {
- SCM_SYSCALL (rv = unlink (SCM_CHARS (oldname)));;
- if (rv != 0)
- /* unlink failed. remove new name */
- SCM_SYSCALL (unlink (SCM_CHARS (newname)));
- }
- SCM_ALLOW_INTS;
- if (rv != 0)
- scm_syserror (s_sys_rename);
- return SCM_UNSPECIFIED;
-#endif
-}
-
-
-SCM_PROC(s_sys_delete_file, "delete-file", 1, 0, 0, scm_sys_delete_file);
-
-SCM
-scm_sys_delete_file (str)
- SCM str;
-{
- int ans;
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_delete_file);
- SCM_SYSCALL (ans = unlink (SCM_CHARS (str)));
- if (ans != 0)
- scm_syserror (s_sys_delete_file);
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC (s_sys_mkdir, "mkdir", 1, 1, 0, scm_sys_mkdir);
-
-SCM
-scm_sys_mkdir (path, mode)
- SCM path;
- SCM mode;
-{
-#ifdef HAVE_MKDIR
- int rv;
- mode_t mask;
- SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_sys_mkdir);
- if (SCM_UNBNDP (mode))
- {
- mask = umask (0);
- umask (mask);
- SCM_SYSCALL (rv = mkdir (SCM_CHARS (path), 0777 ^ mask));
- }
- else
- {
- SCM_ASSERT (SCM_INUMP (mode), mode, SCM_ARG2, s_sys_mkdir);
- SCM_SYSCALL (rv = mkdir (SCM_CHARS (path), SCM_INUM (mode)));
- }
- if (rv != 0)
- scm_syserror (s_sys_mkdir);
- return SCM_UNSPECIFIED;
-#else
- scm_sysmissing (s_sys_mkdir);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-SCM_PROC (s_sys_rmdir, "rmdir", 1, 0, 0, scm_sys_rmdir);
-
-SCM
-scm_sys_rmdir (path)
- SCM path;
-{
-#ifdef HAVE_RMDIR
- int val;
-
- SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, SCM_ARG1, s_sys_rmdir);
- SCM_SYSCALL (val = rmdir (SCM_CHARS (path)));
- if (val != 0)
- scm_syserror (s_sys_rmdir);
- return SCM_UNSPECIFIED;
-#else
- scm_sysmissing (s_sys_rmdir);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-/* {Examining Directories}
- */
-
-long scm_tc16_dir;
-
-SCM_PROC (s_sys_opendir, "opendir", 1, 0, 0, scm_sys_opendir);
-
-SCM
-scm_sys_opendir (dirname)
- SCM dirname;
-{
- DIR *ds;
- SCM dir;
- SCM_ASSERT (SCM_NIMP (dirname) && SCM_STRINGP (dirname), dirname, SCM_ARG1, s_sys_opendir);
- SCM_NEWCELL (dir);
- SCM_DEFER_INTS;
- SCM_SYSCALL (ds = opendir (SCM_CHARS (dirname)));
- if (ds == NULL)
- scm_syserror (s_sys_opendir);
- SCM_SETCAR (dir, scm_tc16_dir | SCM_OPN);
- SCM_SETCDR (dir, ds);
- SCM_ALLOW_INTS;
- return dir;
-}
-
-
-SCM_PROC (s_sys_readdir, "readdir", 1, 0, 0, scm_sys_readdir);
-
-SCM
-scm_sys_readdir (port)
- SCM port;
-{
- struct dirent *rdent;
- SCM_DEFER_INTS;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_sys_readdir);
- errno = 0;
- SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CDR (port)));
- SCM_ALLOW_INTS;
- if (errno != 0)
- scm_syserror (s_sys_readdir);
- return (rdent ? scm_makfromstr (rdent->d_name, NAMLEN (rdent), 0)
- : SCM_EOF_VAL);
-}
-
-
-
-SCM_PROC (s_rewinddir, "rewinddir", 1, 0, 0, scm_rewinddir);
-
-SCM
-scm_rewinddir (port)
- SCM port;
-{
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPDIRP (port), port, SCM_ARG1, s_rewinddir);
- rewinddir ((DIR *) SCM_CDR (port));
- return SCM_UNSPECIFIED;
-}
-
-
-
-SCM_PROC (s_sys_closedir, "closedir", 1, 0, 0, scm_sys_closedir);
-
-SCM
-scm_sys_closedir (port)
- SCM port;
-{
- int sts;
-
- SCM_ASSERT (SCM_NIMP (port) && SCM_DIRP (port), port, SCM_ARG1, s_sys_closedir);
- SCM_DEFER_INTS;
- if (SCM_CLOSEDP (port))
- {
- SCM_ALLOW_INTS;
- return SCM_UNSPECIFIED;
- }
- SCM_SYSCALL (sts = closedir ((DIR *) SCM_CDR (port)));
- if (sts != 0)
- scm_syserror (s_sys_closedir);
- SCM_SETCAR (port, scm_tc16_dir);
- SCM_ALLOW_INTS;
- return SCM_UNSPECIFIED;
-}
-
-
-
-
-static int scm_dir_print SCM_P ((SCM sexp, SCM port, scm_print_state *pstate));
-
-static int
-scm_dir_print (sexp, port, pstate)
- SCM sexp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_prinport (sexp, port, "directory");
- return 1;
-}
-
-
-static scm_sizet scm_dir_free SCM_P ((SCM p));
-
-static scm_sizet
-scm_dir_free (p)
- SCM p;
-{
- if (SCM_OPENP (p))
- closedir ((DIR *) SCM_CDR (p));
- return 0;
-}
-
-static scm_smobfuns dir_smob = {scm_mark0, scm_dir_free, scm_dir_print, 0};
-
-
-/* {Navigating Directories}
- */
-
-
-SCM_PROC (s_sys_chdir, "chdir", 1, 0, 0, scm_sys_chdir);
-
-SCM
-scm_sys_chdir (str)
- SCM str;
-{
- int ans;
-
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_sys_chdir);
- SCM_SYSCALL (ans = chdir (SCM_CHARS (str)));
- if (ans != 0)
- scm_syserror (s_sys_chdir);
- return SCM_UNSPECIFIED;
-}
-
-
-
-SCM_PROC (s_sys_getcwd, "getcwd", 0, 0, 0, scm_sys_getcwd);
-
-SCM
-scm_sys_getcwd ()
-{
-#ifdef HAVE_GETCWD
- char *rv;
-
- scm_sizet size = 100;
- char *wd;
- SCM result;
-
- SCM_DEFER_INTS;
- wd = scm_must_malloc (size, s_sys_getcwd);
- while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
- {
- scm_must_free (wd);
- size *= 2;
- wd = scm_must_malloc (size, s_sys_getcwd);
- }
- if (rv == 0)
- scm_syserror (s_sys_getcwd);
- result = scm_makfromstr (wd, strlen (wd), 0);
- scm_must_free (wd);
- SCM_ALLOW_INTS;
- return result;
-#else
- scm_sysmissing (s_sys_getcwd);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-
-
-static void fill_select_type SCM_P ((SELECT_TYPE * set, SCM list));
-
-static void
-fill_select_type (set, list)
- SELECT_TYPE * set;
- SCM list;
-{
- while (list != SCM_EOL)
- {
- if ( SCM_NIMP (SCM_CAR (list))
- && (scm_tc16_fport == SCM_TYP16 (SCM_CAR (list)))
- && SCM_OPPORTP (SCM_CAR (list)))
- FD_SET (fileno ((FILE *)SCM_STREAM (SCM_CAR (list))), set);
- else if (SCM_INUMP (SCM_CAR (list)))
- FD_SET (SCM_INUM (SCM_CAR (list)), set);
- else if (SCM_NIMP (SCM_CAR (list)) && SCM_FD_P (SCM_CAR (list)))
- FD_SET (SCM_FD (SCM_CAR (list)), set);
- list = SCM_CDR (list);
- }
-}
-
-
-static SCM retrieve_select_type SCM_P ((SELECT_TYPE * set, SCM list));
-
-static SCM
-retrieve_select_type (set, list)
- SELECT_TYPE * set;
- SCM list;
-{
- SCM answer;
- answer = SCM_EOL;
- while (list != SCM_EOL)
- {
- if ( SCM_NIMP (SCM_CAR (list))
- && (scm_tc16_fport == SCM_TYP16 (SCM_CAR (list)))
- && SCM_OPPORTP (SCM_CAR (list)))
- {
- if (FD_ISSET (fileno ((FILE *)SCM_STREAM (SCM_CAR (list))), set))
- answer = scm_cons (SCM_CAR (list), answer);
- }
- else if (SCM_INUMP (SCM_CAR (list)))
- {
- if (FD_ISSET (SCM_INUM (SCM_CAR (list)), set))
- answer = scm_cons (SCM_CAR (list), answer);
- }
- else if (SCM_NIMP (SCM_CAR (list)) && SCM_FD_P (SCM_CAR (list)))
- {
- if (FD_ISSET (SCM_FD (SCM_CAR (list)), set))
- answer = scm_cons (SCM_CAR (list), answer);
- }
- list = SCM_CDR (list);
- }
- return answer;
-}
-
-
-/* {Checking for events}
- */
-
-SCM_PROC (s_sys_select, "select", 3, 2, 0, scm_sys_select);
-
-SCM
-scm_sys_select (reads, writes, excepts, secs, msecs)
- SCM reads;
- SCM writes;
- SCM excepts;
- SCM secs;
- SCM msecs;
-{
-#ifdef HAVE_SELECT
- struct timeval timeout;
- struct timeval * time_p;
- SELECT_TYPE read_set;
- SELECT_TYPE write_set;
- SELECT_TYPE except_set;
- int sreturn;
-
- SCM_ASSERT (-1 < scm_ilength (reads), reads, SCM_ARG1, s_sys_select);
- SCM_ASSERT (-1 < scm_ilength (writes), reads, SCM_ARG1, s_sys_select);
- SCM_ASSERT (-1 < scm_ilength (excepts), reads, SCM_ARG1, s_sys_select);
-
- FD_ZERO (&read_set);
- FD_ZERO (&write_set);
- FD_ZERO (&except_set);
-
- fill_select_type (&read_set, reads);
- fill_select_type (&write_set, writes);
- fill_select_type (&except_set, excepts);
-
- if (SCM_UNBNDP (secs))
- time_p = 0;
- else
- {
- SCM_ASSERT (SCM_INUMP (secs), secs, SCM_ARG4, s_sys_select);
- if (SCM_UNBNDP (msecs))
- msecs = SCM_INUM0;
- else
- SCM_ASSERT (SCM_INUMP (msecs), msecs, SCM_ARG5, s_sys_select);
-
- timeout.tv_sec = SCM_INUM (secs);
- timeout.tv_usec = 1000 * SCM_INUM (msecs);
- time_p = &timeout;
- }
-
- SCM_DEFER_INTS;
- sreturn = select (SELECT_SET_SIZE,
- &read_set, &write_set, &except_set, time_p);
- if (sreturn < 0)
- scm_syserror (s_sys_select);
- SCM_ALLOW_INTS;
- return scm_listify (retrieve_select_type (&read_set, reads),
- retrieve_select_type (&write_set, writes),
- retrieve_select_type (&except_set, excepts),
- SCM_UNDEFINED);
-#else
- scm_sysmissing (s_sys_select);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-/* Check if FILE has characters waiting to be read. */
-
-#ifdef __IBMC__
-# define MSDOS
-#endif
-#ifdef MSDOS
-# ifndef GO32
-# include <io.h>
-# include <conio.h>
-
-int
-scm_input_waiting_p (f, caller)
- FILE *f;
- char *caller;
-{
- if (feof (f))
- return 1;
- if (fileno (f) == fileno (stdin) && (isatty (fileno (stdin))))
- return kbhit ();
- return -1;
-}
-
-# endif
-#else
-# ifdef _DCC
-# include <ioctl.h>
-# else
-# ifndef AMIGA
-# ifndef vms
-# ifdef MWC
-# include <sys/io.h>
-# else
-# ifndef THINK_C
-# ifndef ARM_ULIB
-# include <sys/ioctl.h>
-# endif
-# endif
-# endif
-# endif
-# endif
-# endif
-
-int
-scm_input_waiting_p (f, caller)
- FILE *f;
- char *caller;
-{
- /* Can we return an end-of-file character? */
- if (feof (f))
- return 1;
-
- /* Do we have characters in the stdio buffer? */
-# ifdef FILE_CNT_FIELD
- if (f->FILE_CNT_FIELD > 0)
- return 1;
-# else
-# ifdef FILE_CNT_GPTR
- if (f->_gptr != f->_egptr)
- return 1;
-# else
-# ifdef FILE_CNT_READPTR
- if (f->_IO_read_end != f->_IO_read_ptr)
- return 1;
-# else
- Configure.in could not guess the name of the correct field in a FILE *.
- This function needs to be ported to your system.
- It should return zero iff no characters are waiting to be read.;
-# endif
-# endif
-# endif
-
- /* Is the file prepared to deliver input? */
-# ifdef FIONREAD
- {
- long remir;
- ioctl(fileno(f), FIONREAD, &remir);
- return remir;
- }
-# else
-# ifdef HAVE_SELECT
- {
- struct timeval timeout;
- SELECT_TYPE read_set;
- SELECT_TYPE write_set;
- SELECT_TYPE except_set;
- int fno = fileno ((FILE *)f);
-
- FD_ZERO (&read_set);
- FD_ZERO (&write_set);
- FD_ZERO (&except_set);
-
- FD_SET (fno, &read_set);
-
- timeout.tv_sec = 0;
- timeout.tv_usec = 0;
-
- SCM_DEFER_INTS;
- if (select (SELECT_SET_SIZE,
- &read_set, &write_set, &except_set, &timeout)
- < 0)
- scm_syserror (caller);
- SCM_ALLOW_INTS;
- return FD_ISSET (fno, &read_set);
- }
-# else
- return -1;
-# endif
-# endif
-}
-#endif
-
-
-/* {Symbolic Links}
- */
-
-SCM_PROC (s_sys_symlink, "symlink", 2, 0, 0, scm_sys_symlink);
-
-SCM
-scm_sys_symlink(oldpath, newpath)
- SCM oldpath;
- SCM newpath;
-{
-#ifdef HAVE_SYMLINK
- int val;
-
- SCM_ASSERT(SCM_NIMP(oldpath) && SCM_STRINGP(oldpath), oldpath, SCM_ARG1, s_sys_symlink);
- SCM_ASSERT(SCM_NIMP(newpath) && SCM_STRINGP(newpath), newpath, SCM_ARG2, s_sys_symlink);
- SCM_SYSCALL (val = symlink(SCM_CHARS(oldpath), SCM_CHARS(newpath)));
- if (val != 0)
- scm_syserror (s_sys_symlink);
- return SCM_UNSPECIFIED;
-#else
- scm_sysmissing (s_sys_symlink);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-SCM_PROC (s_sys_readlink, "readlink", 1, 0, 0, scm_sys_readlink);
-
-SCM
-scm_sys_readlink(path)
- SCM path;
-{
-#ifdef HAVE_READLINK
- scm_sizet rv;
- scm_sizet size = 100;
- char *buf;
- SCM result;
- SCM_ASSERT (SCM_NIMP (path) && SCM_STRINGP (path), path, (char *) SCM_ARG1, s_sys_readlink);
- SCM_DEFER_INTS;
- buf = scm_must_malloc (size, s_sys_readlink);
- while ((rv = readlink (SCM_CHARS (path), buf, (scm_sizet) size)) == size)
- {
- scm_must_free (buf);
- size *= 2;
- buf = scm_must_malloc (size, s_sys_readlink);
- }
- if (rv == -1)
- scm_syserror (s_sys_readlink);
- result = scm_makfromstr (buf, rv, 0);
- scm_must_free (buf);
- SCM_ALLOW_INTS;
- return result;
-#else
- scm_sysmissing (s_sys_readlink);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-SCM_PROC (s_sys_lstat, "lstat", 1, 0, 0, scm_sys_lstat);
-
-SCM
-scm_sys_lstat(str)
- SCM str;
-{
-#ifdef HAVE_LSTAT
- int rv;
- struct stat stat_temp;
-
- SCM_ASSERT(SCM_NIMP(str) && SCM_STRINGP(str), str, (char *)SCM_ARG1, s_sys_lstat);
- SCM_SYSCALL(rv = lstat(SCM_CHARS(str), &stat_temp));
- if (rv != 0)
- scm_syserror_msg (s_sys_lstat, "%s: %S",
- scm_listify (scm_makfrom0str (strerror (errno)),
- str,
- SCM_UNDEFINED));
- return scm_stat2scm(&stat_temp);
-#else
- scm_sysmissing (s_sys_lstat);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-SCM_PROC (s_sys_copy_file, "copy-file", 2, 0, 0, scm_sys_copy_file);
-
-SCM
-scm_sys_copy_file (oldfile, newfile)
- SCM oldfile;
- SCM newfile;
-{
- int oldfd, newfd;
- int n;
- char buf[BUFSIZ]; /* this space could be shared. */
- struct stat oldstat;
-
- SCM_ASSERT (SCM_NIMP (oldfile) && SCM_ROSTRINGP (oldfile), oldfile, SCM_ARG1, s_sys_copy_file);
- if (SCM_SUBSTRP (oldfile))
- oldfile = scm_makfromstr (SCM_ROCHARS (oldfile), SCM_ROLENGTH (oldfile), 0);
- SCM_ASSERT (SCM_NIMP (newfile) && SCM_ROSTRINGP (newfile), newfile, SCM_ARG2, s_sys_copy_file);
- if (SCM_SUBSTRP (newfile))
- newfile = scm_makfromstr (SCM_ROCHARS (newfile), SCM_ROLENGTH (newfile), 0);
- if (stat (SCM_ROCHARS (oldfile), &oldstat) == -1)
- scm_syserror (s_sys_copy_file);
- SCM_DEFER_INTS;
- oldfd = open (SCM_ROCHARS (oldfile), O_RDONLY);
- if (oldfd == -1)
- scm_syserror (s_sys_copy_file);
-
- /* use POSIX flags instead of 07777?. */
- newfd = open (SCM_ROCHARS (newfile), O_WRONLY | O_CREAT | O_TRUNC,
- oldstat.st_mode & 07777);
- if (newfd == -1)
- scm_syserror (s_sys_copy_file);
-
- while ((n = read (oldfd, buf, sizeof buf)) > 0)
- if (write (newfd, buf, n) != n)
- {
- close (oldfd);
- close (newfd);
- scm_syserror (s_sys_copy_file);
- }
- close (oldfd);
- if (close (newfd) == -1)
- scm_syserror (s_sys_copy_file);
- SCM_ALLOW_INTS;
- return SCM_UNSPECIFIED;
-}
-
-
-
-void
-scm_init_filesys ()
-{
- scm_add_feature ("i/o-extensions");
-
- scm_tc16_fd = scm_newsmob (&fd_smob);
- scm_tc16_dir = scm_newsmob (&dir_smob);
-
-#include "filesys.x"
-}
diff --git a/libguile/filesys.h b/libguile/filesys.h
deleted file mode 100644
index ff7a28664..000000000
--- a/libguile/filesys.h
+++ /dev/null
@@ -1,105 +0,0 @@
-/* classes: h_files */
-
-#ifndef FILESYSH
-#define FILESYSH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "libguile/__scm.h"
-
-
-
-extern long scm_tc16_fd;
-
-#define SCM_FD_P(x) (SCM_TYP16(x)==(scm_tc16_fd))
-#define SCM_FD_FLAGS(x) (SCM_CAR(x) >> 16)
-#define SCM_FD(x) ((int)SCM_CDR (x))
-
-enum scm_fd_flags
-{
- scm_fd_is_open = 1,
- scm_close_fd_on_gc = 2
-};
-
-
-
-
-extern long scm_tc16_dir;
-#define SCM_DIRP(x) (SCM_TYP16(x)==(scm_tc16_dir))
-#define SCM_OPDIRP(x) (SCM_CAR(x)==(scm_tc16_dir | SCM_OPN))
-
-
-
-
-extern SCM scm_sys_chown SCM_P ((SCM path, SCM owner, SCM group));
-extern SCM scm_sys_chmod SCM_P ((SCM port_or_path, SCM mode));
-extern SCM scm_umask SCM_P ((SCM mode));
-extern SCM scm_intern_fd SCM_P ((int fd, int flags));
-extern SCM scm_sys_open SCM_P ((SCM path, SCM flags, SCM mode));
-extern SCM scm_sys_create SCM_P ((SCM path, SCM mode));
-extern SCM scm_sys_close SCM_P ((SCM sfd));
-extern SCM scm_sys_write_fd SCM_P ((SCM sfd, SCM buf));
-extern SCM scm_sys_read_fd SCM_P ((SCM sfd, SCM buf, SCM offset, SCM length));
-extern SCM scm_sys_lseek SCM_P ((SCM sfd, SCM offset, SCM whence));
-extern SCM scm_sys_dup SCM_P ((SCM oldfd, SCM newfd));
-extern SCM scm_sys_stat SCM_P ((SCM fd_or_path));
-extern SCM scm_sys_link SCM_P ((SCM oldpath, SCM newpath));
-extern SCM scm_sys_rename SCM_P ((SCM oldname, SCM newname));
-extern SCM scm_sys_delete_file SCM_P ((SCM str));
-extern SCM scm_sys_mkdir SCM_P ((SCM path, SCM mode));
-extern SCM scm_sys_rmdir SCM_P ((SCM path));
-extern SCM scm_sys_opendir SCM_P ((SCM dirname));
-extern SCM scm_sys_readdir SCM_P ((SCM port));
-extern SCM scm_rewinddir SCM_P ((SCM port));
-extern SCM scm_sys_closedir SCM_P ((SCM port));
-extern SCM scm_sys_chdir SCM_P ((SCM str));
-extern SCM scm_sys_getcwd SCM_P ((void));
-extern SCM scm_sys_select SCM_P ((SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs));
-extern int scm_input_waiting_p SCM_P ((FILE *file, char *caller));
-extern SCM scm_sys_symlink SCM_P ((SCM oldpath, SCM newpath));
-extern SCM scm_sys_readlink SCM_P ((SCM path));
-extern SCM scm_sys_lstat SCM_P ((SCM str));
-extern SCM scm_sys_copy_file SCM_P ((SCM oldfile, SCM newfile));
-extern void scm_init_filesys SCM_P ((void));
-
-#endif /* FILESYSH */
diff --git a/libguile/fports.c b/libguile/fports.c
deleted file mode 100644
index 928aeeff5..000000000
--- a/libguile/fports.c
+++ /dev/null
@@ -1,400 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "markers.h"
-
-#include "fports.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#else
-scm_sizet fwrite ();
-#endif
-
-
-#ifdef __IBMC__
-#include <io.h>
-#include <direct.h>
-#else
-#ifndef MSDOS
-#ifndef ultrix
-#ifndef vms
-#ifdef _DCC
-#include <ioctl.h>
-#define setbuf(stream, buf) setvbuf(stream, buf, _IONBF, 0)
-#else
-#ifdef MWC
-#include <sys/io.h>
-#else
-#ifndef THINK_C
-#ifndef ARM_ULIB
-#include <sys/ioctl.h>
-#endif
-#endif
-#endif
-#endif
-#endif
-#endif
-#endif
-#endif
-
-
-/* {Ports - file ports}
- *
- */
-
-/* should be called with SCM_DEFER_INTS active */
-
-SCM
-scm_setbuf0 (port)
- SCM port;
-{
-#ifndef NOSETBUF
-#ifndef MSDOS
-#ifdef FIONREAD
-#ifndef ultrix
- SCM_SYSCALL (setbuf ((FILE *)SCM_STREAM (port), 0););
-#endif
-#endif
-#endif
-#endif
- return SCM_UNSPECIFIED;
-}
-
-/* Return the flags that characterize a port based on the mode
- * string used to open a file for that port.
- *
- * See PORT FLAGS in scm.h
- */
-
-long
-scm_mode_bits (modes)
- char *modes;
-{
- return (SCM_OPN
- | (strchr (modes, 'r') || strchr (modes, '+') ? SCM_RDNG : 0)
- | ( strchr (modes, 'w')
- || strchr (modes, 'a')
- || strchr (modes, '+') ? SCM_WRTNG : 0)
- | (strchr (modes, '0') ? SCM_BUF0 : 0));
-}
-
-
-/* scm_open_file
- * Return a new port open on a given file.
- *
- * The mode string must match the pattern: [rwa+]** which
- * is interpreted in the usual unix way.
- *
- * Return the new port.
- */
-SCM_PROC(s_open_file, "open-file", 2, 0, 0, scm_open_file);
-
-SCM
-scm_open_file (filename, modes)
- SCM filename;
- SCM modes;
-{
- SCM port;
- FILE *f;
- char *file;
- char *mode;
-
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_open_file);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_file);
- if (SCM_SUBSTRP (filename))
- filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
- if (SCM_SUBSTRP (modes))
- modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
-
- file = SCM_ROCHARS (filename);
- mode = SCM_ROCHARS (modes);
-
- SCM_NEWCELL (port);
- SCM_DEFER_INTS;
- SCM_SYSCALL (f = fopen (file, mode));
- if (!f)
- {
- scm_syserror_msg (s_open_file, "%s: %S",
- scm_listify (scm_makfrom0str (strerror (errno)),
- filename,
- SCM_UNDEFINED));
- }
- else
- {
- struct scm_port_table * pt;
-
- pt = scm_add_to_port_table (port);
- SCM_SETPTAB_ENTRY (port, pt);
- SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (mode));
- SCM_SETSTREAM (port, (SCM) f);
- if (SCM_BUF0 & SCM_CAR (port))
- scm_setbuf0 (port);
- SCM_PTAB_ENTRY (port)->file_name = filename;
- }
- SCM_ALLOW_INTS;
- return port;
-}
-
-
-/* Build a Scheme port from an open stdio port, FILE.
- MODE indicates whether FILE is open for reading or writing; it uses
- the same notation as open-file's second argument.
- If NAME is non-zero, use it as the port's filename.
-
- scm_stdio_to_port sets the revealed count for FILE's file
- descriptor to 1, so that FILE won't be closed when the port object
- is GC'd. */
-SCM
-scm_stdio_to_port (file, mode, name)
- FILE *file;
- char *mode;
- char *name;
-{
- long mode_bits = scm_mode_bits (mode);
- SCM port;
- struct scm_port_table * pt;
-
- SCM_NEWCELL (port);
- SCM_DEFER_INTS;
- {
- pt = scm_add_to_port_table (port);
- SCM_SETPTAB_ENTRY (port, pt);
- SCM_SETCAR (port, (scm_tc16_fport | mode_bits));
- SCM_SETSTREAM (port, (SCM) file);
- if (SCM_BUF0 & SCM_CAR (port))
- scm_setbuf0 (port);
- SCM_PTAB_ENTRY (port)->file_name = scm_makfrom0str (name);
- }
- SCM_ALLOW_INTS;
- scm_set_port_revealed_x (port, SCM_MAKINUM (1));
- return port;
-}
-
-
-/* Return the mode flags from an open port.
- * Some modes such as "append" are only used when opening
- * a file and are not returned here. */
-
-SCM_PROC(s_port_mode, "port-mode", 1, 0, 0, scm_port_mode);
-
-SCM
-scm_port_mode (port)
- SCM port;
-{
- char modes[3];
- modes[0] = '\0';
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_port_mode);
- if (SCM_CAR (port) & SCM_RDNG) {
- if (SCM_CAR (port) & SCM_WRTNG)
- strcpy (modes, "r+");
- else
- strcpy (modes, "r");
- }
- else if (SCM_CAR (port) & SCM_WRTNG)
- strcpy (modes, "w");
- if (SCM_CAR (port) & SCM_BUF0)
- strcat (modes, "0");
- return scm_makfromstr (modes, strlen (modes), 0);
-}
-
-
-
-static int prinfport SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-
-static int
-prinfport (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- SCM name;
- char * c;
- if (SCM_CLOSEDP (exp))
- {
- c = "file";
- }
- else
- {
- name = SCM_PTAB_ENTRY (exp)->file_name;
- if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
- c = SCM_ROCHARS (name);
- else
- c = "file";
- }
-
- scm_prinport (exp, port, c);
- return !0;
-}
-
-
-
-static int scm_fgetc SCM_P ((FILE * s));
-
-static int
-scm_fgetc (s)
- FILE * s;
-{
- if (feof (s))
- return EOF;
- else
- return fgetc (s);
-}
-
-#ifdef vms
-
-static scm_sizet pwrite SCM_P ((char *ptr, scm_sizet size, nitems, FILE *port));
-
-static scm_sizet
-pwrite (ptr, size, nitems, port)
- char *ptr;
- scm_sizet size, nitems;
- FILE *port;
-{
- scm_sizet len = size * nitems;
- scm_sizet i = 0;
- for (; i < len; i++)
- putc (ptr[i], port);
- return len;
-}
-
-#define ffwrite pwrite
-#else
-#define ffwrite fwrite
-#endif
-
-
-/* This otherwise pointless code helps some poor
- * crippled C compilers cope with life.
- */
-
-static int local_fclose SCM_P ((FILE *fp));
-
-static int
-local_fclose (fp)
- FILE * fp;
-{
- return fclose (fp);
-}
-
-static int local_fflush SCM_P ((FILE *fp));
-
-static int
-local_fflush (fp)
- FILE * fp;
-{
- return fflush (fp);
-}
-
-static int local_fputc SCM_P ((int c, FILE *fp));
-
-static int
-local_fputc (c, fp)
- int c;
- FILE * fp;
-{
- return fputc (c, fp);
-}
-
-static int local_fputs SCM_P ((char *s, FILE *fp));
-
-static int
-local_fputs (s, fp)
- char * s;
- FILE * fp;
-{
- return fputs (s, fp);
-}
-
-static scm_sizet local_ffwrite SCM_P ((void *ptr, int size, int nitems, FILE *fp));
-
-static scm_sizet
-local_ffwrite (ptr, size, nitems, fp)
- void * ptr;
- int size;
- int nitems;
- FILE * fp;
-{
- return ffwrite (ptr, size, nitems, fp);
-}
-
-
-scm_ptobfuns scm_fptob =
-{
- scm_mark0,
- (int (*) SCM_P ((SCM))) local_fclose,
- prinfport,
- 0,
- (int (*) SCM_P ((int, SCM))) local_fputc,
- (int (*) SCM_P ((char *, SCM))) local_fputs,
- (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
- (int (*) SCM_P ((SCM))) local_fflush,
- (int (*) SCM_P ((SCM))) scm_fgetc,
- (int (*) SCM_P ((SCM))) local_fclose
-};
-
-/* {Pipe ports}
- */
-scm_ptobfuns scm_pipob =
-{
- scm_mark0,
- 0, /* replaced by pclose in scm_init_ioext() */
- 0, /* replaced by prinpipe in scm_init_ioext() */
- 0,
- (int (*) SCM_P ((int, SCM))) local_fputc,
- (int (*) SCM_P ((char *, SCM))) local_fputs,
- (scm_sizet (*) SCM_P ((char *, scm_sizet, scm_sizet, SCM))) local_ffwrite,
- (int (*) SCM_P ((SCM))) local_fflush,
- (int (*) SCM_P ((SCM))) scm_fgetc,
- 0
-}; /* replaced by pclose in scm_init_ioext() */
-
-void
-scm_init_fports ()
-{
-#include "fports.x"
-}
diff --git a/libguile/fports.h b/libguile/fports.h
deleted file mode 100644
index 13802d345..000000000
--- a/libguile/fports.h
+++ /dev/null
@@ -1,65 +0,0 @@
-/* classes: h_files */
-
-#ifndef FPORTSH
-#define FPORTSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-#include "libguile/ports.h"
-
-
-
-extern scm_ptobfuns scm_fptob;
-extern scm_ptobfuns scm_pipob;
-
-
-
-extern SCM scm_setbuf0 SCM_P ((SCM port));
-extern long scm_mode_bits SCM_P ((char *modes));
-extern SCM scm_open_file SCM_P ((SCM filename, SCM modes));
-extern SCM scm_stdio_to_port SCM_P ((FILE *file, char *name, char *modes));
-extern SCM scm_port_mode SCM_P ((SCM port));
-extern void scm_init_fports SCM_P ((void));
-
-#endif /* FPORTSH */
diff --git a/libguile/gc.c b/libguile/gc.c
deleted file mode 100644
index cd4a249d7..000000000
--- a/libguile/gc.c
+++ /dev/null
@@ -1,1825 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include <stdio.h>
-#include "_scm.h"
-#include "stime.h"
-#include "stackchk.h"
-#include "struct.h"
-#include "genio.h"
-#include "weaks.h"
-#include "smob.h"
-#include "unif.h"
-#include "async.h"
-
-#include "gc.h"
-
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef __STDC__
-#include <stdarg.h>
-#define var_start(x, y) va_start(x, y)
-#else
-#include <varargs.h>
-#define var_start(x, y) va_start(x)
-#endif
-
-
-/* {heap tuning parameters}
- *
- * These are parameters for controlling memory allocation. The heap
- * is the area out of which scm_cons, and object headers are allocated.
- *
- * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
- * 64 bit machine. The units of the _SIZE parameters are bytes.
- * Cons pairs and object headers occupy one heap cell.
- *
- * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
- * allocated initially the heap will grow by half its current size
- * each subsequent time more heap is needed.
- *
- * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
- * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
- * heap is needed. SCM_HEAP_SEG_SIZE must fit into type scm_sizet. This code
- * is in scm_init_storage() and alloc_some_heap() in sys.c
- *
- * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
- * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
- *
- * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
- * is needed.
- *
- * INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
- * trigger a GC.
- *
- * SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be
- * reclaimed by a GC triggered by must_malloc. If less than this is
- * reclaimed, the trigger threshold is raised. [I don't know what a
- * good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to
- * work around a oscillation that caused almost constant GC.]
- */
-
-#define SCM_INIT_HEAP_SIZE (32768L*sizeof(scm_cell))
-#define SCM_MIN_HEAP_SEG_SIZE (2048L*sizeof(scm_cell))
-#ifdef _QC
-# define SCM_HEAP_SEG_SIZE 32768L
-#else
-# ifdef sequent
-# define SCM_HEAP_SEG_SIZE (7000L*sizeof(scm_cell))
-# else
-# define SCM_HEAP_SEG_SIZE (16384L*sizeof(scm_cell))
-# endif
-#endif
-#define SCM_EXPHEAP(scm_heap_size) (scm_heap_size*2)
-#define SCM_INIT_MALLOC_LIMIT 100000
-#define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10)
-
-/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find scm_cell aligned inner
- bounds for allocated storage */
-
-#ifdef PROT386
-/*in 386 protected mode we must only adjust the offset */
-# define CELL_UP(p) MK_FP(FP_SEG(p), ~7&(FP_OFF(p)+7))
-# define CELL_DN(p) MK_FP(FP_SEG(p), ~7&FP_OFF(p))
-#else
-# ifdef _UNICOS
-# define CELL_UP(p) (SCM_CELLPTR)(~1L & ((long)(p)+1L))
-# define CELL_DN(p) (SCM_CELLPTR)(~1L & (long)(p))
-# else
-# define CELL_UP(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & ((long)(p)+sizeof(scm_cell)-1L))
-# define CELL_DN(p) (SCM_CELLPTR)(~(sizeof(scm_cell)-1L) & (long)(p))
-# endif /* UNICOS */
-#endif /* PROT386 */
-
-
-
-/* scm_freelist
- * is the head of freelist of cons pairs.
- */
-SCM scm_freelist = SCM_EOL;
-
-/* scm_mtrigger
- * is the number of bytes of must_malloc allocation needed to trigger gc.
- */
-long scm_mtrigger;
-
-
-/* scm_gc_heap_lock
- * If set, don't expand the heap. Set only during gc, during which no allocation
- * is supposed to take place anyway.
- */
-int scm_gc_heap_lock = 0;
-
-/* GC Blocking
- * Don't pause for collection if this is set -- just
- * expand the heap.
- */
-
-int scm_block_gc = 1;
-
-/* If fewer than MIN_GC_YIELD cells are recovered during a garbage
- * collection (GC) more space is allocated for the heap.
- */
-#define MIN_GC_YIELD (scm_heap_size/4)
-
-/* During collection, this accumulates objects holding
- * weak references.
- */
-SCM *scm_weak_vectors;
-int scm_weak_size;
-int scm_n_weak;
-
-/* GC Statistics Keeping
- */
-unsigned long scm_cells_allocated = 0;
-unsigned long scm_mallocated = 0;
-unsigned long scm_gc_cells_collected;
-unsigned long scm_gc_malloc_collected;
-unsigned long scm_gc_ports_collected;
-unsigned long scm_gc_rt;
-unsigned long scm_gc_time_taken = 0;
-
-SCM_SYMBOL (sym_cells_allocated, "cells-allocated");
-SCM_SYMBOL (sym_heap_size, "cell-heap-size");
-SCM_SYMBOL (sym_mallocated, "bytes-malloced");
-SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold");
-SCM_SYMBOL (sym_heap_segments, "cell-heap-segments");
-SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
-
-
-struct scm_heap_seg_data
-{
- /* lower and upper bounds of the segment */
- SCM_CELLPTR bounds[2];
-
- /* address of the head-of-freelist pointer for this segment's cells.
- All segments usually point to the same one, scm_freelist. */
- SCM *freelistp;
-
- /* number of SCM words per object in this segment */
- int ncells;
-
- /* If SEG_DATA->valid is non-zero, the conservative marking
- functions will apply SEG_DATA->valid to the purported pointer and
- SEG_DATA, and mark the object iff the function returns non-zero.
- At the moment, I don't think anyone uses this. */
- int (*valid) ();
-};
-
-
-
-
-static void scm_mark_weak_vector_spines SCM_P ((void));
-static scm_sizet init_heap_seg SCM_P ((SCM_CELLPTR, scm_sizet, int, SCM *));
-static void alloc_some_heap SCM_P ((int, SCM *));
-
-
-
-/* Debugging functions. */
-
-#ifdef DEBUG_FREELIST
-
-/* Return the number of the heap segment containing CELL. */
-static int
-which_seg (SCM cell)
-{
- int i;
-
- for (i = 0; i < scm_n_heap_segs; i++)
- if (SCM_PTR_LE (scm_heap_table[i].bounds[0], (SCM_CELLPTR) cell)
- && SCM_PTR_GT (scm_heap_table[i].bounds[1], (SCM_CELLPTR) cell))
- return i;
- fprintf (stderr, "which_seg: can't find segment containing cell %lx\n",
- cell);
- abort ();
-}
-
-
-SCM_PROC (s_map_free_list, "map-free-list", 0, 0, 0, scm_map_free_list);
-SCM
-scm_map_free_list ()
-{
- int last_seg = -1, count = 0;
- SCM f;
-
- fprintf (stderr, "%d segments total\n", scm_n_heap_segs);
- for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f))
- {
- int this_seg = which_seg (f);
-
- if (this_seg != last_seg)
- {
- if (last_seg != -1)
- fprintf (stderr, " %5d cells in segment %d\n", count, last_seg);
- last_seg = this_seg;
- count = 0;
- }
- count++;
- }
- if (last_seg != -1)
- fprintf (stderr, " %5d cells in segment %d\n", count, last_seg);
-
- fflush (stderr);
-
- return SCM_UNSPECIFIED;
-}
-
-
-/* Number of calls to SCM_NEWCELL since startup. */
-static unsigned long scm_newcell_count;
-
-/* Search freelist for anything that isn't marked as a free cell.
- Abort if we find something. */
-static void
-scm_check_freelist ()
-{
- SCM f;
- int i = 0;
-
- for (f = scm_freelist; SCM_NIMP (f); f = SCM_CDR (f), i++)
- if (SCM_CAR (f) != (SCM) scm_tc_free_cell)
- {
- fprintf (stderr, "Bad cell in freelist on newcell %lu: %d'th elt\n",
- scm_newcell_count, i);
- fflush (stderr);
- abort ();
- }
-}
-
-static int scm_debug_check_freelist = 0;
-void
-scm_debug_newcell (SCM *into)
-{
- scm_newcell_count++;
- if (scm_debug_check_freelist)
- scm_check_freelist ();
-
- /* The rest of this is supposed to be identical to the SCM_NEWCELL
- macro. */
- if (SCM_IMP (scm_freelist))
- *into = scm_gc_for_newcell ();
- else
- {
- *into = scm_freelist;
- scm_freelist = SCM_CDR (scm_freelist);
- ++scm_cells_allocated;
- }
-}
-
-#endif /* DEBUG_FREELIST */
-
-
-
-/* {Scheme Interface to GC}
- */
-
-SCM_PROC (s_gc_stats, "gc-stats", 0, 0, 0, scm_gc_stats);
-SCM
-scm_gc_stats ()
-{
- int i;
- int n;
- SCM heap_segs;
- SCM local_scm_mtrigger;
- SCM local_scm_mallocated;
- SCM local_scm_heap_size;
- SCM local_scm_cells_allocated;
- SCM local_scm_gc_time_taken;
- SCM answer;
-
- SCM_DEFER_INTS;
- scm_block_gc = 1;
- retry:
- heap_segs = SCM_EOL;
- n = scm_n_heap_segs;
- for (i = scm_n_heap_segs; i--; )
- heap_segs = scm_cons (scm_cons (scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[1]),
- scm_ulong2num ((unsigned long)scm_heap_table[i].bounds[0])),
- heap_segs);
- if (scm_n_heap_segs != n)
- goto retry;
- scm_block_gc = 0;
-
- local_scm_mtrigger = scm_mtrigger;
- local_scm_mallocated = scm_mallocated;
- local_scm_heap_size = scm_heap_size;
- local_scm_cells_allocated = scm_cells_allocated;
- local_scm_gc_time_taken = scm_gc_time_taken;
-
- answer = scm_listify (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)),
- scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)),
- scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)),
- scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)),
- scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)),
- scm_cons (sym_heap_segments, heap_segs),
- SCM_UNDEFINED);
- SCM_ALLOW_INTS;
- return answer;
-}
-
-
-void
-scm_gc_start (what)
- char *what;
-{
- scm_gc_rt = SCM_INUM (scm_get_internal_run_time ());
- scm_gc_cells_collected = 0;
- scm_gc_malloc_collected = 0;
- scm_gc_ports_collected = 0;
-}
-
-void
-scm_gc_end ()
-{
- scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt;
- scm_gc_time_taken = scm_gc_time_taken + scm_gc_rt;
- scm_take_signal (SCM_GC_SIGNAL);
-}
-
-
-SCM_PROC(s_object_address, "object-address", 1, 0, 0, scm_object_addr);
-SCM
-scm_object_addr (obj)
- SCM obj;
-{
- return scm_ulong2num ((unsigned long)obj);
-}
-
-
-SCM_PROC(s_gc, "gc", 0, 0, 0, scm_gc);
-SCM
-scm_gc ()
-{
- SCM_DEFER_INTS;
- scm_igc ("call");
- SCM_ALLOW_INTS;
- return SCM_UNSPECIFIED;
-}
-
-
-
-/* {C Interface For When GC is Triggered}
- */
-
-void
-scm_gc_for_alloc (ncells, freelistp)
- int ncells;
- SCM * freelistp;
-{
- SCM_REDEFER_INTS;
- scm_igc ("cells");
- if ((scm_gc_cells_collected < MIN_GC_YIELD) || SCM_IMP (*freelistp))
- {
- alloc_some_heap (ncells, freelistp);
- }
- SCM_REALLOW_INTS;
-}
-
-
-SCM
-scm_gc_for_newcell ()
-{
- SCM fl;
- scm_gc_for_alloc (1, &scm_freelist);
- fl = scm_freelist;
- scm_freelist = SCM_CDR (fl);
- return fl;
-}
-
-void
-scm_igc (what)
- char *what;
-{
- int j;
-
-#ifdef USE_THREADS
- /* During the critical section, only the current thread may run. */
- SCM_THREAD_CRITICAL_SECTION_START;
-#endif
-
- scm_gc_start (what);
- if (!scm_stack_base || scm_block_gc)
- {
- scm_gc_end ();
- return;
- }
-
- ++scm_gc_heap_lock;
- scm_n_weak = 0;
-
- /* unprotect any struct types with no instances */
-#if 0
- {
- SCM type_list;
- SCM * pos;
-
- pos = &scm_type_obj_list;
- type_list = scm_type_obj_list;
- while (type_list != SCM_EOL)
- if (SCM_VELTS (SCM_CAR (type_list))[scm_struct_i_refcnt])
- {
- pos = SCM_CDRLOC (type_list);
- type_list = SCM_CDR (type_list);
- }
- else
- {
- *pos = SCM_CDR (type_list);
- type_list = SCM_CDR (type_list);
- }
- }
-#endif
-
- /* flush dead entries from the continuation stack */
- {
- int x;
- int bound;
- SCM * elts;
- elts = SCM_VELTS (scm_continuation_stack);
- bound = SCM_LENGTH (scm_continuation_stack);
- x = SCM_INUM (scm_continuation_stack_ptr);
- while (x < bound)
- {
- elts[x] = SCM_BOOL_F;
- ++x;
- }
- }
-
-#ifndef USE_THREADS
-
- /* Protect from the C stack. This must be the first marking
- * done because it provides information about what objects
- * are "in-use" by the C code. "in-use" objects are those
- * for which the values from SCM_LENGTH and SCM_CHARS must remain
- * usable. This requirement is stricter than a liveness
- * requirement -- in particular, it constrains the implementation
- * of scm_vector_set_length_x.
- */
- SCM_FLUSH_REGISTER_WINDOWS;
- /* This assumes that all registers are saved into the jmp_buf */
- setjmp (scm_save_regs_gc_mark);
- scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
- ( (scm_sizet) (sizeof (SCM_STACKITEM) - 1 +
- sizeof scm_save_regs_gc_mark)
- / sizeof (SCM_STACKITEM)));
-
- {
- /* stack_len is long rather than scm_sizet in order to guarantee that
- &stack_len is long aligned */
-#ifdef SCM_STACK_GROWS_UP
-#ifdef nosve
- long stack_len = (SCM_STACKITEM *) (&stack_len) - scm_stack_base;
-#else
- long stack_len = scm_stack_size (scm_stack_base);
-#endif
- scm_mark_locations (scm_stack_base, (scm_sizet) stack_len);
-#else
-#ifdef nosve
- long stack_len = scm_stack_base - (SCM_STACKITEM *) (&stack_len);
-#else
- long stack_len = scm_stack_size (scm_stack_base);
-#endif
- scm_mark_locations ((scm_stack_base - stack_len), (scm_sizet) stack_len);
-#endif
- }
-
-#else /* USE_THREADS */
-
- /* Mark every thread's stack and registers */
- scm_threads_mark_stacks();
-
-#endif /* USE_THREADS */
-
- /* FIXME: insert a phase to un-protect string-data preserved
- * in scm_vector_set_length_x.
- */
-
- j = SCM_NUM_PROTECTS;
- while (j--)
- scm_gc_mark (scm_sys_protects[j]);
-
-#ifndef USE_THREADS
- scm_gc_mark (scm_root->handle);
-#endif
-
- scm_mark_weak_vector_spines ();
-
- scm_gc_sweep ();
-
- --scm_gc_heap_lock;
- scm_gc_end ();
-
-#ifdef USE_THREADS
- SCM_THREAD_CRITICAL_SECTION_END;
-#endif
-}
-
-
-/* {Mark/Sweep}
- */
-
-
-
-/* Mark an object precisely.
- */
-void
-scm_gc_mark (p)
- SCM p;
-{
- register long i;
- register SCM ptr;
-
- ptr = p;
-
-gc_mark_loop:
- if (SCM_IMP (ptr))
- return;
-
-gc_mark_nimp:
- if (SCM_NCELLP (ptr))
- scm_wta (ptr, "rogue pointer in ", "heap");
-
- switch (SCM_TYP7 (ptr))
- {
- case scm_tcs_cons_nimcar:
- if (SCM_GCMARKP (ptr))
- break;
- SCM_SETGCMARK (ptr);
- if (SCM_IMP (SCM_CDR (ptr))) /* SCM_IMP works even with a GC mark */
- {
- ptr = SCM_CAR (ptr);
- goto gc_mark_nimp;
- }
- scm_gc_mark (SCM_CAR (ptr));
- ptr = SCM_GCCDR (ptr);
- goto gc_mark_nimp;
- case scm_tcs_cons_imcar:
- if (SCM_GCMARKP (ptr))
- break;
- SCM_SETGCMARK (ptr);
- ptr = SCM_GCCDR (ptr);
- goto gc_mark_loop;
- case scm_tcs_cons_gloc:
- if (SCM_GCMARKP (ptr))
- break;
- SCM_SETGCMARK (ptr);
- {
- SCM vcell;
- vcell = SCM_CAR (ptr) - 1L;
- switch (SCM_CDR (vcell))
- {
- default:
- scm_gc_mark (vcell);
- ptr = SCM_GCCDR (ptr);
- goto gc_mark_loop;
- case 1: /* ! */
- case 0: /* ! */
- {
- SCM layout;
- SCM * vtable_data;
- int len;
- char * fields_desc;
- register SCM * mem;
- register int x;
-
- vtable_data = (SCM *)vcell;
- layout = vtable_data[scm_struct_i_layout];
- len = SCM_LENGTH (layout);
- fields_desc = SCM_CHARS (layout);
- /* We're using SCM_GCCDR here like STRUCT_DATA, except
- that it removes the mark */
- mem = (SCM *)SCM_GCCDR (ptr);
-
- if (len)
- {
- for (x = 0; x < len - 2; x += 2, ++mem)
- if (fields_desc[x] == 'p')
- scm_gc_mark (*mem);
- if (fields_desc[x] == 'p')
- {
- if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
- for (x = *mem; x; --x)
- scm_gc_mark (*++mem);
- else
- scm_gc_mark (*mem);
- }
- }
- if (!SCM_CDR (vcell))
- {
- SCM_SETGCMARK (vcell);
- ptr = vtable_data[scm_struct_i_vtable];
- goto gc_mark_loop;
- }
- }
- }
- }
- break;
- case scm_tcs_closures:
- if (SCM_GCMARKP (ptr))
- break;
- SCM_SETGCMARK (ptr);
- if (SCM_IMP (SCM_CDR (ptr)))
- {
- ptr = SCM_CLOSCAR (ptr);
- goto gc_mark_nimp;
- }
- scm_gc_mark (SCM_CLOSCAR (ptr));
- ptr = SCM_GCCDR (ptr);
- goto gc_mark_nimp;
- case scm_tc7_vector:
- case scm_tc7_lvector:
-#ifdef CCLO
- case scm_tc7_cclo:
-#endif
- if (SCM_GC8MARKP (ptr))
- break;
- SCM_SETGC8MARK (ptr);
- i = SCM_LENGTH (ptr);
- if (i == 0)
- break;
- while (--i > 0)
- if (SCM_NIMP (SCM_VELTS (ptr)[i]))
- scm_gc_mark (SCM_VELTS (ptr)[i]);
- ptr = SCM_VELTS (ptr)[0];
- goto gc_mark_loop;
- case scm_tc7_contin:
- if SCM_GC8MARKP
- (ptr) break;
- SCM_SETGC8MARK (ptr);
- scm_mark_locations (SCM_VELTS (ptr),
- (scm_sizet)
- (SCM_LENGTH (ptr) +
- (sizeof (SCM_STACKITEM) + -1 + sizeof (scm_contregs)) /
- sizeof (SCM_STACKITEM)));
- break;
- case scm_tc7_bvect:
- case scm_tc7_byvect:
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_svect:
-#ifdef LONGLONGS
- case scm_tc7_llvect:
-#endif
-
- case scm_tc7_string:
- case scm_tc7_mb_string:
- SCM_SETGC8MARK (ptr);
- break;
-
- case scm_tc7_substring:
- case scm_tc7_mb_substring:
- if (SCM_GC8MARKP(ptr))
- break;
- SCM_SETGC8MARK (ptr);
- ptr = SCM_CDR (ptr);
- goto gc_mark_loop;
-
- case scm_tc7_wvect:
- if (SCM_GC8MARKP(ptr))
- break;
- scm_weak_vectors[scm_n_weak++] = ptr;
- if (scm_n_weak >= scm_weak_size)
- {
- SCM_SYSCALL (scm_weak_vectors =
- (SCM *) realloc ((char *) scm_weak_vectors,
- sizeof (SCM *) * (scm_weak_size *= 2)));
- if (scm_weak_vectors == NULL)
- {
- scm_gen_puts (scm_regular_string,
- "weak vector table",
- scm_cur_errp);
- scm_gen_puts (scm_regular_string,
- "\nFATAL ERROR DURING CRITICAL SCM_CODE SECTION\n",
- scm_cur_errp);
- exit(SCM_EXIT_FAILURE);
- }
- }
- SCM_SETGC8MARK (ptr);
- if (SCM_IS_WHVEC_ANY (ptr))
- {
- int x;
- int len;
- int weak_keys;
- int weak_values;
-
- len = SCM_LENGTH (ptr);
- weak_keys = SCM_IS_WHVEC (ptr) || SCM_IS_WHVEC_B (ptr);
- weak_values = SCM_IS_WHVEC_V (ptr) || SCM_IS_WHVEC_B (ptr);
-
- for (x = 0; x < len; ++x)
- {
- SCM alist;
- alist = SCM_VELTS (ptr)[x];
- /* mark everything on the alist
- * except the keys or values, according to weak_values and weak_keys.
- */
- while ( SCM_NIMP (alist)
- && SCM_CONSP (alist)
- && !SCM_GCMARKP (alist)
- && SCM_NIMP (SCM_CAR (alist))
- && SCM_CONSP (SCM_CAR (alist)))
- {
- SCM kvpair;
- SCM next_alist;
-
- kvpair = SCM_CAR (alist);
- next_alist = SCM_CDR (alist);
- /*
- * Do not do this:
- * SCM_SETGCMARK (alist);
- * SCM_SETGCMARK (kvpair);
- *
- * It may be that either the key or value is protected by
- * an escaped reference to part of the spine of this alist.
- * If we mark the spine here, and only mark one or neither of the
- * key and value, they may never be properly marked.
- * This leads to a horrible situation in which an alist containing
- * freelist cells is exported.
- *
- * So only mark the spines of these arrays last of all marking.
- * If somebody confuses us by constructing a weak vector
- * with a circular alist then we are hosed, but at least we
- * won't prematurely drop table entries.
- */
- if (!weak_keys)
- scm_gc_mark (SCM_CAR (kvpair));
- if (!weak_values)
- scm_gc_mark (SCM_GCCDR (kvpair));
- alist = next_alist;
- }
- if (SCM_NIMP (alist))
- scm_gc_mark (alist);
- }
- }
- break;
-
- case scm_tc7_msymbol:
- if (SCM_GC8MARKP(ptr))
- break;
- SCM_SETGC8MARK (ptr);
- scm_gc_mark (SCM_SYMBOL_FUNC (ptr));
- ptr = SCM_SYMBOL_PROPS (ptr);
- goto gc_mark_loop;
- case scm_tc7_ssymbol:
- if (SCM_GC8MARKP(ptr))
- break;
- SCM_SETGC8MARK (ptr);
- break;
- case scm_tcs_subrs:
- ptr = (SCM)(scm_heap_org + (((unsigned long)SCM_CAR (ptr)) >> 8));
- goto gc_mark_loop;
- case scm_tc7_port:
- i = SCM_PTOBNUM (ptr);
- if (!(i < scm_numptob))
- goto def;
- if (SCM_GC8MARKP (ptr))
- break;
- if (SCM_PTAB_ENTRY(ptr))
- scm_gc_mark (SCM_PTAB_ENTRY(ptr)->file_name);
- ptr = (scm_ptobs[i].mark) (ptr);
- goto gc_mark_loop;
- break;
- case scm_tc7_smob:
- if (SCM_GC8MARKP (ptr))
- break;
- switch SCM_TYP16 (ptr)
- { /* should be faster than going through scm_smobs */
- case scm_tc_free_cell:
- /* printf("found free_cell %X ", ptr); fflush(stdout); */
- SCM_SETGC8MARK (ptr);
- SCM_SETCDR (ptr, SCM_EOL);
- break;
- case scm_tcs_bignums:
- case scm_tc16_flo:
- SCM_SETGC8MARK (ptr);
- break;
- default:
- i = SCM_SMOBNUM (ptr);
- if (!(i < scm_numsmob))
- goto def;
- ptr = (scm_smobs[i].mark) (ptr);
- goto gc_mark_loop;
- }
- break;
- default:
- def:scm_wta (ptr, "unknown type in ", "gc_mark");
- }
-}
-
-
-/* Mark a Region Conservatively
- */
-
-void
-scm_mark_locations (x, n)
- SCM_STACKITEM x[];
- scm_sizet n;
-{
- register long m = n;
- register int i, j;
- register SCM_CELLPTR ptr;
-
- while (0 <= --m)
- if SCM_CELLP (*(SCM **) & x[m])
- {
- ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & x[m]));
- i = 0;
- j = scm_n_heap_segs - 1;
- if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
- && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
- {
- while (i <= j)
- {
- int seg_id;
- seg_id = -1;
- if ( (i == j)
- || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
- seg_id = i;
- else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
- seg_id = j;
- else
- {
- int k;
- k = (i + j) / 2;
- if (k == i)
- break;
- if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
- {
- j = k;
- ++i;
- if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
- continue;
- else
- break;
- }
- else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
- {
- i = k;
- --j;
- if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
- continue;
- else
- break;
- }
- }
- if ( !scm_heap_table[seg_id].valid
- || scm_heap_table[seg_id].valid (ptr,
- &scm_heap_table[seg_id]))
- scm_gc_mark (*(SCM *) & x[m]);
- break;
- }
-
- }
- }
-}
-
-
-/* The following is a C predicate which determines if an SCM value can be
- regarded as a pointer to a cell on the heap. The code is duplicated
- from scm_mark_locations. */
-
-
-int
-scm_cellp (value)
- SCM value;
-{
- register int i, j;
- register SCM_CELLPTR ptr;
-
- if SCM_CELLP (*(SCM **) & value)
- {
- ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value));
- i = 0;
- j = scm_n_heap_segs - 1;
- if ( SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr)
- && SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
- {
- while (i <= j)
- {
- int seg_id;
- seg_id = -1;
- if ( (i == j)
- || SCM_PTR_GT (scm_heap_table[i].bounds[1], ptr))
- seg_id = i;
- else if (SCM_PTR_LE (scm_heap_table[j].bounds[0], ptr))
- seg_id = j;
- else
- {
- int k;
- k = (i + j) / 2;
- if (k == i)
- break;
- if (SCM_PTR_GT (scm_heap_table[k].bounds[1], ptr))
- {
- j = k;
- ++i;
- if (SCM_PTR_LE (scm_heap_table[i].bounds[0], ptr))
- continue;
- else
- break;
- }
- else if (SCM_PTR_LE (scm_heap_table[k].bounds[0], ptr))
- {
- i = k;
- --j;
- if (SCM_PTR_GT (scm_heap_table[j].bounds[1], ptr))
- continue;
- else
- break;
- }
- }
- if ( !scm_heap_table[seg_id].valid
- || scm_heap_table[seg_id].valid (ptr,
- &scm_heap_table[seg_id]))
- return 1;
- break;
- }
-
- }
- }
- return 0;
-}
-
-
-static void
-scm_mark_weak_vector_spines ()
-{
- int i;
-
- for (i = 0; i < scm_n_weak; ++i)
- {
- if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i]))
- {
- SCM *ptr;
- SCM obj;
- int j;
- int n;
-
- obj = scm_weak_vectors[i];
- ptr = SCM_VELTS (scm_weak_vectors[i]);
- n = SCM_LENGTH (scm_weak_vectors[i]);
- for (j = 0; j < n; ++j)
- {
- SCM alist;
-
- alist = ptr[j];
- while ( SCM_NIMP (alist)
- && SCM_CONSP (alist)
- && !SCM_GCMARKP (alist)
- && SCM_NIMP (SCM_CAR (alist))
- && SCM_CONSP (SCM_CAR (alist)))
- {
- SCM_SETGCMARK (alist);
- SCM_SETGCMARK (SCM_CAR (alist));
- alist = SCM_GCCDR (alist);
- }
- }
- }
- }
-}
-
-
-
-void
-scm_gc_sweep ()
-{
- register SCM_CELLPTR ptr;
-#ifdef SCM_POINTERS_MUNGED
- register SCM scmptr;
-#else
-#undef scmptr
-#define scmptr (SCM)ptr
-#endif
- register SCM nfreelist;
- register SCM *hp_freelist;
- register long n;
- register long m;
- register scm_sizet j;
- register int span;
- scm_sizet i;
- scm_sizet seg_size;
-
- n = 0;
- m = 0;
-
- /* Reset all free list pointers. We'll reconstruct them completely
- while scanning. */
- for (i = 0; i < scm_n_heap_segs; i++)
- *scm_heap_table[i].freelistp = SCM_EOL;
-
- for (i = 0; i < scm_n_heap_segs; i++)
- {
- /* Unmarked cells go onto the front of the freelist this heap
- segment points to. Rather than updating the real freelist
- pointer as we go along, we accumulate the new head in
- nfreelist. Then, if it turns out that the entire segment is
- free, we free (i.e., malloc's free) the whole segment, and
- simply don't assign nfreelist back into the real freelist. */
- hp_freelist = scm_heap_table[i].freelistp;
- nfreelist = *hp_freelist;
-
- span = scm_heap_table[i].ncells;
- ptr = CELL_UP (scm_heap_table[i].bounds[0]);
- seg_size = CELL_DN (scm_heap_table[i].bounds[1]) - ptr;
- for (j = seg_size + span; j -= span; ptr += span)
- {
-#ifdef SCM_POINTERS_MUNGED
- scmptr = PTR2SCM (ptr);
-#endif
- switch SCM_TYP7 (scmptr)
- {
- case scm_tcs_cons_gloc:
- if (SCM_GCMARKP (scmptr))
- {
- if (SCM_CDR (SCM_CAR (scmptr) - 1) == (SCM)1)
- SCM_SETCDR (SCM_CAR (scmptr) - 1, (SCM) 0);
- goto cmrkcontinue;
- }
- {
- SCM vcell;
- vcell = SCM_CAR (scmptr) - 1L;
-
- if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1))
- {
- SCM *p = (SCM *) SCM_GCCDR (scmptr);
- m += p[scm_struct_i_n_words] * sizeof (SCM);
- /* I feel like I'm programming in BCPL here... */
- free ((char *) p[scm_struct_i_ptr]);
- }
- }
- break;
- case scm_tcs_cons_imcar:
- case scm_tcs_cons_nimcar:
- case scm_tcs_closures:
- if (SCM_GCMARKP (scmptr))
- goto cmrkcontinue;
- break;
- case scm_tc7_wvect:
- if (SCM_GC8MARKP (scmptr))
- {
- goto c8mrkcontinue;
- }
- else
- {
- m += (1 + SCM_LENGTH (scmptr)) * sizeof (SCM);
- scm_must_free ((char *)(SCM_VELTS (scmptr) - 1));
- break;
- }
-
- case scm_tc7_vector:
- case scm_tc7_lvector:
-#ifdef CCLO
- case scm_tc7_cclo:
-#endif
- if (SCM_GC8MARKP (scmptr))
- goto c8mrkcontinue;
-
- m += (SCM_LENGTH (scmptr) * sizeof (SCM));
- freechars:
- scm_must_free (SCM_CHARS (scmptr));
- /* SCM_SETCHARS(scmptr, 0);*/
- break;
- case scm_tc7_bvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += sizeof (long) * ((SCM_HUGE_LENGTH (scmptr) + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
- goto freechars;
- case scm_tc7_byvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (char);
- goto freechars;
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (long);
- goto freechars;
- case scm_tc7_svect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (short);
- goto freechars;
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (long_long);
- goto freechars;
-#endif
- case scm_tc7_fvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (float);
- goto freechars;
- case scm_tc7_dvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * sizeof (double);
- goto freechars;
- case scm_tc7_cvect:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double);
- goto freechars;
- case scm_tc7_substring:
- case scm_tc7_mb_substring:
- if (SCM_GC8MARKP (scmptr))
- goto c8mrkcontinue;
- break;
- case scm_tc7_string:
- case scm_tc7_mb_string:
- if (SCM_GC8MARKP (scmptr))
- goto c8mrkcontinue;
- m += SCM_HUGE_LENGTH (scmptr) + 1;
- goto freechars;
- case scm_tc7_msymbol:
- if (SCM_GC8MARKP (scmptr))
- goto c8mrkcontinue;
- m += ( SCM_LENGTH (scmptr)
- + 1
- + sizeof (SCM) * ((SCM *)SCM_CHARS (scmptr) - SCM_SLOTS(scmptr)));
- scm_must_free ((char *)SCM_SLOTS (scmptr));
- break;
- case scm_tc7_contin:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += SCM_LENGTH (scmptr) * sizeof (SCM_STACKITEM) + sizeof (scm_contregs);
- goto freechars;
- case scm_tc7_ssymbol:
- if SCM_GC8MARKP(scmptr)
- goto c8mrkcontinue;
- break;
- case scm_tcs_subrs:
- continue;
- case scm_tc7_port:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- if SCM_OPENP (scmptr)
- {
- int k = SCM_PTOBNUM (scmptr);
- if (!(k < scm_numptob))
- goto sweeperr;
- /* Keep "revealed" ports alive. */
- if (scm_revealed_count(scmptr) > 0)
- continue;
- /* Yes, I really do mean scm_ptobs[k].free */
- /* rather than ftobs[k].close. .close */
- /* is for explicit CLOSE-PORT by user */
- (scm_ptobs[k].free) (SCM_STREAM (scmptr));
- SCM_SETSTREAM (scmptr, 0);
- scm_remove_from_port_table (scmptr);
- scm_gc_ports_collected++;
- SCM_SETAND_CAR (scmptr, ~SCM_OPN);
- }
- break;
- case scm_tc7_smob:
- switch SCM_GCTYP16 (scmptr)
- {
- case scm_tc_free_cell:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- break;
-#ifdef SCM_BIGDIG
- case scm_tcs_bignums:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- m += (SCM_NUMDIGS (scmptr) * SCM_BITSPERDIG / SCM_CHAR_BIT);
- goto freechars;
-#endif /* def SCM_BIGDIG */
- case scm_tc16_flo:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
- switch ((int) (SCM_CAR (scmptr) >> 16))
- {
- case (SCM_IMAG_PART | SCM_REAL_PART) >> 16:
- m += sizeof (double);
- case SCM_REAL_PART >> 16:
- case SCM_IMAG_PART >> 16:
- m += sizeof (double);
- goto freechars;
- case 0:
- break;
- default:
- goto sweeperr;
- }
- break;
- default:
- if SCM_GC8MARKP (scmptr)
- goto c8mrkcontinue;
-
- {
- int k;
- k = SCM_SMOBNUM (scmptr);
- if (!(k < scm_numsmob))
- goto sweeperr;
- m += (scm_smobs[k].free) ((SCM) scmptr);
- break;
- }
- }
- break;
- default:
- sweeperr:scm_wta (scmptr, "unknown type in ", "gc_sweep");
- }
- n += span;
-#if 0
- if (SCM_CAR (scmptr) == (SCM) scm_tc_free_cell)
- exit (2);
-#endif
- /* Stick the new cell on the front of nfreelist. */
- SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
- SCM_SETCDR (scmptr, nfreelist);
- nfreelist = scmptr;
-
- continue;
- c8mrkcontinue:
- SCM_CLRGC8MARK (scmptr);
- continue;
- cmrkcontinue:
- SCM_CLRGCMARK (scmptr);
- }
-#ifdef GC_FREE_SEGMENTS
- if (n == seg_size)
- {
- scm_heap_size -= seg_size;
- free ((char *) scm_heap_table[i].bounds[0]);
- scm_heap_table[i].bounds[0] = 0;
- for (j = i + 1; j < scm_n_heap_segs; j++)
- scm_heap_table[j - 1] = scm_heap_table[j];
- scm_n_heap_segs -= 1;
- i--; /* We need to scan the segment just moved. */
- }
- else
-#endif /* ifdef GC_FREE_SEGMENTS */
- /* Update the real freelist pointer to point to the head of
- the list of free cells we've built for this segment. */
- *hp_freelist = nfreelist;
-
-#ifdef DEBUG_FREELIST
- scm_check_freelist ();
- scm_map_free_list ();
-#endif
-
- scm_gc_cells_collected += n;
- n = 0;
- }
- /* Scan weak vectors. */
- {
- SCM *ptr;
- for (i = 0; i < scm_n_weak; ++i)
- {
- if (!SCM_IS_WHVEC_ANY (scm_weak_vectors[i]))
- {
- ptr = SCM_VELTS (scm_weak_vectors[i]);
- n = SCM_LENGTH (scm_weak_vectors[i]);
- for (j = 0; j < n; ++j)
- if (SCM_NIMP (ptr[j]) && SCM_FREEP (ptr[j]))
- ptr[j] = SCM_BOOL_F;
- }
- else /* if (SCM_IS_WHVEC_ANY (scm_weak_vectors[i])) */
- {
- SCM obj;
- obj = scm_weak_vectors[i];
- ptr = SCM_VELTS (scm_weak_vectors[i]);
- n = SCM_LENGTH (scm_weak_vectors[i]);
- for (j = 0; j < n; ++j)
- {
- SCM * fixup;
- SCM alist;
- int weak_keys;
- int weak_values;
-
- weak_keys = SCM_IS_WHVEC (obj) || SCM_IS_WHVEC_B (obj);
- weak_values = SCM_IS_WHVEC_V (obj) || SCM_IS_WHVEC_B (obj);
-
- fixup = ptr + j;
- alist = *fixup;
-
- while (SCM_NIMP (alist)
- && SCM_CONSP (alist)
- && SCM_NIMP (SCM_CAR (alist))
- && SCM_CONSP (SCM_CAR (alist)))
- {
- SCM key;
- SCM value;
-
- key = SCM_CAAR (alist);
- value = SCM_CDAR (alist);
- if ( (weak_keys && SCM_NIMP (key) && SCM_FREEP (key))
- || (weak_values && SCM_NIMP (value) && SCM_FREEP (value)))
- {
- *fixup = SCM_CDR (alist);
- }
- else
- fixup = SCM_CDRLOC (alist);
- alist = SCM_CDR (alist);
- }
- }
- }
- }
- }
- scm_cells_allocated = (scm_heap_size - scm_gc_cells_collected);
- scm_mallocated -= m;
- scm_gc_malloc_collected = m;
-}
-
-
-
-
-/* {Front end to malloc}
- *
- * scm_must_malloc, scm_must_realloc, scm_must_free
- *
- * These functions provide services comperable to malloc, realloc, and
- * free. They are for allocating malloced parts of scheme objects.
- * The primary purpose of the front end is to impose calls to gc.
- */
-
-/* scm_must_malloc
- * Return newly malloced storage or throw an error.
- *
- * The parameter WHAT is a string for error reporting.
- * If the threshold scm_mtrigger will be passed by this
- * allocation, or if the first call to malloc fails,
- * garbage collect -- on the presumption that some objects
- * using malloced storage may be collected.
- *
- * The limit scm_mtrigger may be raised by this allocation.
- */
-char *
-scm_must_malloc (len, what)
- long len;
- char *what;
-{
- char *ptr;
- scm_sizet size = len;
- long nm = scm_mallocated + size;
- if (len != size)
- malerr:
- scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what);
- if ((nm <= scm_mtrigger))
- {
- SCM_SYSCALL (ptr = (char *) malloc (size));
- if (NULL != ptr)
- {
- scm_mallocated = nm;
- return ptr;
- }
- }
-
- scm_igc (what);
- nm = scm_mallocated + size;
- SCM_SYSCALL (ptr = (char *) malloc (size));
- if (NULL != ptr)
- {
- scm_mallocated = nm;
- if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) {
- if (nm > scm_mtrigger)
- scm_mtrigger = nm + nm / 2;
- else
- scm_mtrigger += scm_mtrigger / 2;
- }
- return ptr;
- }
- goto malerr;
-}
-
-
-/* scm_must_realloc
- * is similar to scm_must_malloc.
- */
-char *
-scm_must_realloc (where, olen, len, what)
- char *where;
- long olen;
- long len;
- char *what;
-{
- char *ptr;
- scm_sizet size = len;
- long nm = scm_mallocated + size - olen;
- if (len != size)
- ralerr:
- scm_wta (SCM_MAKINUM (len), (char *) SCM_NALLOC, what);
- if ((nm <= scm_mtrigger))
- {
- SCM_SYSCALL (ptr = (char *) realloc (where, size));
- if (NULL != ptr)
- {
- scm_mallocated = nm;
- return ptr;
- }
- }
- scm_igc (what);
- nm = scm_mallocated + size - olen;
- SCM_SYSCALL (ptr = (char *) realloc (where, size));
- if (NULL != ptr)
- {
- scm_mallocated = nm;
- if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) {
- if (nm > scm_mtrigger)
- scm_mtrigger = nm + nm / 2;
- else
- scm_mtrigger += scm_mtrigger / 2;
- }
- return ptr;
- }
- goto ralerr;
-}
-
-void
-scm_must_free (obj)
- char *obj;
-{
- if (obj)
- free (obj);
- else
- scm_wta (SCM_INUM0, "already free", "");
-}
-
-
-
-
-/* {Heap Segments}
- *
- * Each heap segment is an array of objects of a particular size.
- * Every segment has an associated (possibly shared) freelist.
- * A table of segment records is kept that records the upper and
- * lower extents of the segment; this is used during the conservative
- * phase of gc to identify probably gc roots (because they point
- * into valid segments at reasonable offsets).
- */
-
-/* scm_expmem
- * is true if the first segment was smaller than INIT_HEAP_SEG.
- * If scm_expmem is set to one, subsequent segment allocations will
- * allocate segments of size SCM_EXPHEAP(scm_heap_size).
- */
-int scm_expmem = 0;
-
-/* scm_heap_org
- * is the lowest base address of any heap segment.
- */
-SCM_CELLPTR scm_heap_org;
-
-struct scm_heap_seg_data * scm_heap_table = 0;
-int scm_n_heap_segs = 0;
-
-/* scm_heap_size
- * is the total number of cells in heap segments.
- */
-long scm_heap_size = 0;
-
-/* init_heap_seg
- * initializes a new heap segment and return the number of objects it contains.
- *
- * The segment origin, segment size in bytes, and the span of objects
- * in cells are input parameters. The freelist is both input and output.
- *
- * This function presume that the scm_heap_table has already been expanded
- * to accomodate a new segment record.
- */
-
-
-static scm_sizet
-init_heap_seg (seg_org, size, ncells, freelistp)
- SCM_CELLPTR seg_org;
- scm_sizet size;
- int ncells;
- SCM *freelistp;
-{
- register SCM_CELLPTR ptr;
-#ifdef SCM_POINTERS_MUNGED
- register SCM scmptr;
-#else
-#undef scmptr
-#define scmptr ptr
-#endif
- SCM_CELLPTR seg_end;
- scm_sizet new_seg_index;
- scm_sizet n_new_objects;
-
- if (seg_org == NULL)
- return 0;
-
- ptr = seg_org;
-
- /* Compute the ceiling on valid object pointers w/in this segment.
- */
- seg_end = CELL_DN ((char *) ptr + size);
-
- /* Find the right place and insert the segment record.
- *
- */
- for (new_seg_index = 0;
- ( (new_seg_index < scm_n_heap_segs)
- && SCM_PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org));
- new_seg_index++)
- ;
-
- {
- int i;
- for (i = scm_n_heap_segs; i > new_seg_index; --i)
- scm_heap_table[i] = scm_heap_table[i - 1];
- }
-
- ++scm_n_heap_segs;
-
- scm_heap_table[new_seg_index].valid = 0;
- scm_heap_table[new_seg_index].ncells = ncells;
- scm_heap_table[new_seg_index].freelistp = freelistp;
- scm_heap_table[new_seg_index].bounds[0] = (SCM_CELLPTR)ptr;
- scm_heap_table[new_seg_index].bounds[1] = (SCM_CELLPTR)seg_end;
-
-
- /* Compute the least valid object pointer w/in this segment
- */
- ptr = CELL_UP (ptr);
-
-
- n_new_objects = seg_end - ptr;
-
- /* Prepend objects in this segment to the freelist.
- */
- while (ptr < seg_end)
- {
-#ifdef SCM_POINTERS_MUNGED
- scmptr = PTR2SCM (ptr);
-#endif
- SCM_SETCAR (scmptr, (SCM) scm_tc_free_cell);
- SCM_SETCDR (scmptr, PTR2SCM (ptr + ncells));
- ptr += ncells;
- }
-
- ptr -= ncells;
-
- /* Patch up the last freelist pointer in the segment
- * to join it to the input freelist.
- */
- SCM_SETCDR (PTR2SCM (ptr), *freelistp);
- *freelistp = PTR2SCM (CELL_UP (seg_org));
-
- scm_heap_size += (ncells * n_new_objects);
- return size;
-#ifdef scmptr
-#undef scmptr
-#endif
-}
-
-
-static void
-alloc_some_heap (ncells, freelistp)
- int ncells;
- SCM * freelistp;
-{
- struct scm_heap_seg_data * tmptable;
- SCM_CELLPTR ptr;
- scm_sizet len;
-
- /* Critical code sections (such as the garbage collector)
- * aren't supposed to add heap segments.
- */
- if (scm_gc_heap_lock)
- scm_wta (SCM_UNDEFINED, "need larger initial", "heap");
-
- /* Expand the heap tables to have room for the new segment.
- * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
- * only if the allocation of the segment itself succeeds.
- */
- len = (1 + scm_n_heap_segs) * sizeof (struct scm_heap_seg_data);
-
- SCM_SYSCALL (tmptable = ((struct scm_heap_seg_data *)
- realloc ((char *)scm_heap_table, len)));
- if (!tmptable)
- scm_wta (SCM_UNDEFINED, "could not grow", "hplims");
- else
- scm_heap_table = tmptable;
-
-
- /* Pick a size for the new heap segment.
- * The rule for picking the size of a segment is explained in
- * gc.h
- */
- if (scm_expmem)
- {
- len = (scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell));
- if ((scm_sizet) (SCM_EXPHEAP (scm_heap_size) * sizeof (scm_cell)) != len)
- len = 0;
- }
- else
- len = SCM_HEAP_SEG_SIZE;
-
- {
- scm_sizet smallest;
-
- smallest = (ncells * sizeof (scm_cell));
- if (len < smallest)
- len = (ncells * sizeof (scm_cell));
-
- /* Allocate with decaying ambition. */
- while ((len >= SCM_MIN_HEAP_SEG_SIZE)
- && (len >= smallest))
- {
- SCM_SYSCALL (ptr = (SCM_CELLPTR) malloc (len));
- if (ptr)
- {
- init_heap_seg (ptr, len, ncells, freelistp);
- return;
- }
- len /= 2;
- }
- }
-
- scm_wta (SCM_UNDEFINED, "could not grow", "heap");
-}
-
-
-
-SCM_PROC (s_unhash_name, "unhash-name", 1, 0, 0, scm_unhash_name);
-SCM
-scm_unhash_name (name)
- SCM name;
-{
- int x;
- int bound;
- SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_unhash_name);
- SCM_DEFER_INTS;
- bound = scm_n_heap_segs;
- for (x = 0; x < bound; ++x)
- {
- SCM_CELLPTR p;
- SCM_CELLPTR pbound;
- p = (SCM_CELLPTR)scm_heap_table[x].bounds[0];
- pbound = (SCM_CELLPTR)scm_heap_table[x].bounds[1];
- while (p < pbound)
- {
- SCM incar;
- incar = p->car;
- if (1 == (7 & (int)incar))
- {
- --incar;
- if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name))
- && (SCM_CDR (incar) != 0)
- && (SCM_CDR (incar) != 1))
- {
- p->car = name;
- }
- }
- ++p;
- }
- }
- SCM_ALLOW_INTS;
- return name;
-}
-
-
-
-/* {GC Protection Helper Functions}
- */
-
-
-void
-scm_remember (ptr)
- SCM * ptr;
-{}
-
-
-#ifdef __STDC__
-SCM
-scm_return_first (SCM elt, ...)
-#else
-SCM
-scm_return_first (elt, va_alist)
- SCM elt;
- va_dcl
-#endif
-{
- return elt;
-}
-
-
-SCM
-scm_permanent_object (obj)
- SCM obj;
-{
- SCM_REDEFER_INTS;
- scm_permobjs = scm_cons (obj, scm_permobjs);
- SCM_REALLOW_INTS;
- return obj;
-}
-
-
-
-int
-scm_init_storage (init_heap_size)
- long init_heap_size;
-{
- scm_sizet j;
-
- j = SCM_NUM_PROTECTS;
- while (j)
- scm_sys_protects[--j] = SCM_BOOL_F;
- scm_block_gc = 1;
- scm_freelist = SCM_EOL;
- scm_expmem = 0;
-
- j = SCM_HEAP_SEG_SIZE;
- scm_mtrigger = SCM_INIT_MALLOC_LIMIT;
- scm_heap_table = ((struct scm_heap_seg_data *)
- scm_must_malloc (sizeof (struct scm_heap_seg_data), "hplims"));
- if (0L == init_heap_size)
- init_heap_size = SCM_INIT_HEAP_SIZE;
- j = init_heap_size;
- if ((init_heap_size != j)
- || !init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist))
- {
- j = SCM_HEAP_SEG_SIZE;
- if (!init_heap_seg ((SCM_CELLPTR) malloc (j), j, 1, &scm_freelist))
- return 1;
- }
- else
- scm_expmem = 1;
- scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0]);
- /* scm_hplims[0] can change. do not remove scm_heap_org */
- if (!(scm_weak_vectors = (SCM *) malloc ((scm_weak_size = 32) * sizeof(SCM *))))
- return 1;
-
- /* Initialise the list of ports. */
- scm_port_table = (struct scm_port_table **) malloc ((long) (sizeof (struct scm_port_table)
- * scm_port_table_room));
- if (!scm_port_table)
- return 1;
-
-
- scm_undefineds = scm_cons (SCM_UNDEFINED, SCM_EOL);
- SCM_SETCDR (scm_undefineds, scm_undefineds);
-
- scm_listofnull = scm_cons (SCM_EOL, SCM_EOL);
- scm_nullstr = scm_makstr (0L, 0);
- scm_nullvect = scm_make_vector (SCM_INUM0, SCM_UNDEFINED, SCM_UNDEFINED);
- scm_symhash = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED);
- scm_weak_symhash = scm_make_weak_key_hash_table ((SCM) SCM_MAKINUM (scm_symhash_dim));
- scm_symhash_vars = scm_make_vector ((SCM) SCM_MAKINUM (scm_symhash_dim), SCM_EOL, SCM_UNDEFINED);
- scm_stand_in_procs = SCM_EOL;
- scm_permobjs = SCM_EOL;
- scm_asyncs = SCM_EOL;
- scm_sysintern ("most-positive-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
- scm_sysintern ("most-negative-fixnum", (SCM) SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
-#ifdef SCM_BIGDIG
- scm_sysintern ("bignum-radix", SCM_MAKINUM (SCM_BIGRAD));
-#endif
- return 0;
-}
-
-
-void
-scm_init_gc ()
-{
-#include "gc.x"
-}
diff --git a/libguile/gc.h b/libguile/gc.h
deleted file mode 100644
index 0a1f20549..000000000
--- a/libguile/gc.h
+++ /dev/null
@@ -1,101 +0,0 @@
-/* classes: h_files */
-
-#ifndef GCH
-#define GCH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-#define SCM_FREEP(x) (SCM_CAR(x)==scm_tc_free_cell)
-#define SCM_NFREEP(x) (!SCM_FREEP(x))
-
-extern struct scm_heap_seg_data *scm_heap_table;
-extern int scm_n_heap_segs;
-extern int scm_take_stdin;
-extern int scm_block_gc;
-extern int scm_gc_heap_lock;
-
-
-
-extern long scm_heap_size;
-extern SCM_CELLPTR scm_heap_org;
-extern SCM scm_freelist;
-extern unsigned long scm_gc_cells_collected;
-extern unsigned long scm_gc_malloc_collected;
-extern unsigned long scm_gc_ports_collected;
-extern unsigned long scm_cells_allocated;
-extern unsigned long scm_mallocated;
-extern long scm_mtrigger;
-
-#ifdef DEBUG_FREELIST
-extern void scm_debug_newcell SCM_P ((SCM *into));
-#endif
-
-
-
-extern SCM scm_object_addr SCM_P ((SCM obj));
-extern SCM scm_unhash_name SCM_P ((SCM name));
-extern SCM scm_gc_stats SCM_P ((void));
-extern void scm_gc_start SCM_P ((char *what));
-extern void scm_gc_end SCM_P ((void));
-extern SCM scm_gc SCM_P ((void));
-extern void scm_gc_for_alloc SCM_P ((int ncells, SCM * freelistp));
-extern SCM scm_gc_for_newcell SCM_P ((void));
-extern void scm_igc SCM_P ((char *what));
-extern void scm_gc_mark SCM_P ((SCM p));
-extern void scm_mark_locations SCM_P ((SCM_STACKITEM x[], scm_sizet n));
-extern int scm_cellp SCM_P ((SCM value));
-extern void scm_gc_sweep SCM_P ((void));
-extern char * scm_must_malloc SCM_P ((long len, char *what));
-extern char * scm_must_realloc SCM_P ((char *where, long olen, long len,
- char *what));
-extern void scm_must_free SCM_P ((char *obj));
-extern void scm_remember SCM_P ((SCM * ptr));
-extern SCM scm_return_first SCM_P ((SCM elt, ...));
-extern SCM scm_permanent_object SCM_P ((SCM obj));
-extern SCM scm_protect_object SCM_P ((SCM obj));
-extern SCM scm_unprotect_object SCM_P ((SCM obj));
-extern int scm_init_storage SCM_P ((long init_heap_size));
-extern void scm_init_gc SCM_P ((void));
-#endif /* GCH */
diff --git a/libguile/gdb_interface.h b/libguile/gdb_interface.h
deleted file mode 100644
index dd8aac3d9..000000000
--- a/libguile/gdb_interface.h
+++ /dev/null
@@ -1,127 +0,0 @@
-/* Simple interpreter interface for GDB, the GNU debugger.
- Copyright (C) 1996 Mikael Djurfeldt.
-
-This file is part of GDB.
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-The author can be reached at djurfeldt@nada.kth.se
-Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
-
-#ifndef GDB_INTERFACE_H
-#define GDB_INTERFACE_H
-
-/* This is the header file for GDB's interpreter interface. The
- interpreter must supply definitions of all symbols declared in this
- file.
-
- Before including this file, you must #define GDB_TYPE to be the
- data type used for communication with the interpreter. */
-
-/* The following macro can be used to anchor the symbols of the
- interface in your main program. This is necessary if the interface
- is defined in a library, such as Guile. */
-
-#define GDB_INTERFACE \
-void *gdb_interface[] = { \
- &gdb_options, \
- &gdb_language, \
- &gdb_result, \
- &gdb_output, \
- &gdb_output_length, \
- gdb_maybe_valid_type_p, \
- gdb_read, \
- gdb_eval, \
- gdb_print, \
- gdb_binding \
-}; \
-
-
-/* GDB_OPTIONS is a set of flags informing gdb what features are present
- in the interface. Currently only one option is supported: */
-
-/* GDB_HAVE_BINDINGS: Set this bit if your interpreter can create new
- top level bindings on demand (through gdb_top_level_binding) */
-
-#define GDB_HAVE_BINDINGS 1
-
-extern unsigned short gdb_options;
-
-/* GDB_LANGUAGE holds the name of the preferred language mode for this
- interpreter. For lisp interpreters, the suggested mode is "lisp/c". */
-
-extern char *gdb_language;
-
-/* GDB_RESULT is used for passing results from the interpreter to GDB */
-
-extern GDB_TYPE gdb_result;
-
-/* The interpreter passes strings to GDB in GDB_OUTPUT and
- GDB_OUTPUT_LENGTH. GDB_OUTPUT should hold the pointer to the
- string. GDB_OUTPUT_LENGTH should hold its length. The string
- doesn't need to be terminated by '\0'. */
-
-extern char *gdb_output;
-
-extern int gdb_output_length;
-
-/* Return TRUE if the interpreter regards VALUE's type as valid. A
- lazy implementation is allowed to pass TRUE always. FALSE should
- only be returned when it is certain that VALUE is not valid.
-
- In the "lisp/c" language mode, this is used to heuristically
- discriminate lisp values from C values during printing. */
-
-extern int gdb_maybe_valid_type_p SCM_P ((GDB_TYPE value));
-
-/* Parse expression in string STR. Store result in GDB_RESULT, then
- return 0 to indicate success. On error, return -1 to indicate
- failure. An error string can be passed in GDB_OUTPUT and
- GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero if
- no message is passed. Please note that the resulting value should
- be protected against garbage collection. */
-
-extern int gdb_read SCM_P ((char *str));
-
-/* Evaluate expression EXP. Store result in GDB_RESULT, then return 0
- to indicate success. On error, return -1 to indicate failure. Any
- output (both on success and failure) can be passed in GDB_OUTPUT
- and GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero
- if no output is passed. Please note that the resulting lisp object
- should be protected against garbage collection. */
-
-extern int gdb_eval SCM_P ((GDB_TYPE exp));
-
-/* Print VALUE. Store output in GDB_OUTPUT and GDB_OUTPUT_LENGTH.
- Return 0 to indicate success. On error, return -1 to indicate
- failure. GDB will not look at GDB_OUTPUT or GDB_OUTPUT_LENGTH on
- failure. Note that this function should be robust against strange
- values. It could in fact be passed any kind of value. */
-
-extern int gdb_print SCM_P ((GDB_TYPE value));
-
-/* Bind NAME to VALUE in interpreter. (GDB has previously obtained
- NAME by passing a string to gdb_read.) Return 0 to indicate
- success or -1 to indicate failure. This feature is optional. GDB
- will only call this function if the GDB_HAVE_BINDINGS flag is set
- in gdb_options. Note that GDB may call this function many times
- for the same name.
-
- For scheme interpreters, this function should introduce top-level
- bindings. */
-
-extern int gdb_binding SCM_P ((GDB_TYPE name, GDB_TYPE value));
-
-#endif /* GDB_INTERFACE_H */
diff --git a/libguile/gdbint.c b/libguile/gdbint.c
deleted file mode 100644
index 3ce4f2eca..000000000
--- a/libguile/gdbint.c
+++ /dev/null
@@ -1,325 +0,0 @@
-/* GDB interface for Guile
- * Copyright (C) 1996 Mikael Djurfeldt
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- *
- * The author can be reached at djurfeldt@nada.kth.se
- * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
- */
-
-#include <stdio.h>
-#include "_scm.h"
-#include "tag.h"
-#include "strports.h"
-#include "read.h"
-#include "eval.h"
-#include "chars.h"
-
-#include "gdbint.h"
-
-/* {Support for debugging with gdb}
- *
- * TODO:
- *
- * 1. Redirect outputs
- * 2. Catch errors
- * 3. Prevent print from causing segmentation fault when given broken pairs
- */
-
-#include <stdio.h>
-#include "_scm.h"
-
-#define GDB_TYPE SCM
-
-#include "gdb_interface.h"
-
-
-
-/* Be carefull when this macro is true.
- scm_gc_heap_lock is set during gc.
- */
-#define SCM_GC_P (scm_gc_heap_lock)
-
-/* Macros that encapsulate blocks of code which can be called by the
- * debugger.
- */
-#define SCM_BEGIN_FOREIGN_BLOCK \
-{ \
- old_ints = scm_ints_disabled; scm_ints_disabled = 1; \
- old_gc = scm_block_gc; scm_block_gc = 1; \
- scm_print_carefully_p = 1; \
-} \
-
-
-#define SCM_END_FOREIGN_BLOCK \
-{ \
- scm_print_carefully_p = 0; \
- scm_block_gc = old_gc; \
- scm_ints_disabled = old_ints; \
-} \
-
-
-#define RESET_STRING { gdb_output_length = 0; }
-
-#define SEND_STRING(str) \
-{ \
- gdb_output = str; \
- gdb_output_length = strlen (str); \
-} \
-
-
-/* {Gdb interface}
- */
-
-unsigned short gdb_options = GDB_HAVE_BINDINGS;
-
-char *gdb_language = "lisp/c";
-
-SCM gdb_result;
-
-char *gdb_output;
-
-int gdb_output_length;
-
-int scm_print_carefully_p;
-
-static SCM gdb_input_port;
-static int port_mark_p, stream_mark_p, string_mark_p;
-
-static SCM tok_buf;
-static int tok_buf_mark_p;
-
-static SCM gdb_output_port;
-static int old_ints, old_gc;
-
-
-static void unmark_port SCM_P ((SCM port));
-
-static void
-unmark_port (port)
- SCM port;
-{
- SCM stream, string;
- port_mark_p = SCM_GC8MARKP (port);
- SCM_CLRGC8MARK (port);
- stream = SCM_STREAM (port);
- stream_mark_p = SCM_GCMARKP (stream);
- SCM_CLRGCMARK (stream);
- string = SCM_CDR (stream);
- string_mark_p = SCM_GC8MARKP (string);
- SCM_CLRGC8MARK (string);
-}
-
-
-static void remark_port SCM_P ((SCM port));
-
-static void
-remark_port (port)
- SCM port;
-{
- SCM stream = SCM_STREAM (port);
- SCM string = SCM_CDR (stream);
- if (string_mark_p) SCM_SETGC8MARK (string);
- if (stream_mark_p) SCM_SETGCMARK (stream);
- if (port_mark_p) SCM_SETGC8MARK (port);
-}
-
-
-int
-gdb_maybe_valid_type_p (value)
- SCM value;
-{
- if (SCM_IMP (value) || scm_cellp (value))
- return scm_tag (value) != SCM_MAKINUM (-1);
- return 0;
-}
-
-
-int
-gdb_read (str)
- char *str;
-{
- SCM ans;
- int status = 0;
- RESET_STRING;
- /* Need to be restrictive about what to read? */
- if (SCM_GC_P)
- {
- char *p;
- for (p = str; *p != '\0'; ++p)
- switch (*p)
- {
- case '(':
- case '\'':
- case '"':
- SEND_STRING ("Can't read this kind of expressions during gc");
- return -1;
- case '#':
- if (*++p == '\0')
- goto premature;
- if (*p == '\\')
- {
- if (*++p != '\0')
- continue;
- premature:
- SEND_STRING ("Premature end of lisp expression");
- return -1;
- }
- default:
- continue;
- }
- }
- SCM_BEGIN_FOREIGN_BLOCK;
- unmark_port (gdb_input_port);
- /* Replace string in input port and reset stream */
- ans = SCM_CDR (SCM_STREAM (gdb_input_port));
- SCM_SETCHARS (ans, str);
- SCM_SETLENGTH (ans, strlen (str), scm_tc7_string);
- SCM_SETCAR (SCM_STREAM (gdb_input_port), SCM_INUM0);
- /* Read one object */
- tok_buf_mark_p = SCM_GC8MARKP (tok_buf);
- SCM_CLRGC8MARK (tok_buf);
- ans = scm_lreadr (&tok_buf, gdb_input_port, 0, SCM_BOOL_F, &ans);
- if (SCM_GC_P)
- {
- if (SCM_NIMP (ans))
- {
- SEND_STRING ("Non-immediate created during gc. Memory may be trashed.");
- status = -1;
- goto exit;
- }
- }
- gdb_result = ans;
- /* Protect answer from future GC */
- if (SCM_NIMP (ans))
- scm_permanent_object (ans);
-exit:
- if (tok_buf_mark_p)
- SCM_SETGC8MARK (tok_buf);
- remark_port (gdb_input_port);
- SCM_END_FOREIGN_BLOCK;
- return status;
-}
-
-
-int
-gdb_eval (exp)
- SCM exp;
-{
- RESET_STRING;
- if (SCM_IMP (exp))
- {
- gdb_result = exp;
- return 0;
- }
- if (SCM_GC_P)
- {
- SEND_STRING ("Can't evaluate lisp expressions during gc");
- return -1;
- }
- SCM_BEGIN_FOREIGN_BLOCK;
- {
- SCM env = scm_top_level_env (SCM_CDR (scm_top_level_lookup_closure_var));
- gdb_result = scm_permanent_object (scm_ceval (exp, env));
- }
- SCM_END_FOREIGN_BLOCK;
- return 0;
-}
-
-
-int
-gdb_print (obj)
- SCM obj;
-{
- RESET_STRING;
- SCM_BEGIN_FOREIGN_BLOCK;
- /* Reset stream */
- SCM_SETCAR (SCM_STREAM (gdb_output_port), SCM_INUM0);
- scm_write (obj, gdb_output_port);
- scm_display (SCM_MAKICHR (0), gdb_output_port);
- SEND_STRING (SCM_CHARS (SCM_CDR (SCM_STREAM (gdb_output_port))));
- SCM_END_FOREIGN_BLOCK;
- return 0;
-}
-
-
-int
-gdb_binding (name, value)
- SCM name;
- SCM value;
-{
- RESET_STRING;
- if (SCM_GC_P)
- {
- SEND_STRING ("Can't create new bindings during gc");
- return -1;
- }
- SCM_BEGIN_FOREIGN_BLOCK;
- {
- SCM vcell = scm_sym2vcell (name,
- SCM_CDR (scm_top_level_lookup_closure_var),
- SCM_BOOL_T);
- SCM_SETCDR (vcell, value);
- }
- SCM_END_FOREIGN_BLOCK;
- return 0;
-}
-
-void
-scm_init_gdbint ()
-{
- static char *s = "scm_init_gdb_interface";
- SCM port;
-
- scm_print_carefully_p = 0;
-
- port = scm_mkstrport (SCM_INUM0,
- scm_make_string (SCM_MAKINUM (80), SCM_UNDEFINED),
- SCM_OPN | SCM_WRTNG,
- s);
- gdb_output_port = scm_permanent_object (port);
-
- port = scm_mkstrport (SCM_INUM0,
- scm_make_string (SCM_MAKINUM (0), SCM_UNDEFINED),
- SCM_OPN | SCM_RDNG,
- s);
- gdb_input_port = scm_permanent_object (port);
-
- tok_buf = scm_permanent_object (scm_makstr (30L, 0));
-}
diff --git a/libguile/gdbint.h b/libguile/gdbint.h
deleted file mode 100644
index bf12524f6..000000000
--- a/libguile/gdbint.h
+++ /dev/null
@@ -1,58 +0,0 @@
-/* classes: h_files */
-
-#ifndef GDBINTH
-#define GDBINTH
-/* Copyright (C) 1996 Mikael Djurfeldt
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- *
- * The author can be reached at djurfeldt@nada.kth.se
- * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-extern int scm_print_carefully_p;
-
-extern void scm_init_gdbint SCM_P ((void));
-
-#endif /* GDBINTH */
diff --git a/libguile/genio.c b/libguile/genio.c
deleted file mode 100644
index 5ebd86e3f..000000000
--- a/libguile/genio.c
+++ /dev/null
@@ -1,508 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "extchrs.h"
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-
-#include "genio.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-
-
-
-static void scm_putc SCM_P ((int c, SCM port));
-
-static void
-scm_putc (c, port)
- int c;
- SCM port;
-{
- scm_sizet i = SCM_PTOBNUM (port);
- SCM_SYSCALL ((scm_ptobs[i].fputc) (c, SCM_STREAM (port)));
-}
-
-
-
-static void scm_puts SCM_P ((char *s, SCM port));
-
-static void
-scm_puts (s, port)
- char *s;
- SCM port;
-{
- scm_sizet i = SCM_PTOBNUM (port);
- SCM_SYSCALL ((scm_ptobs[i].fputs) (s, SCM_STREAM (port)));
-#ifdef TRANSCRIPT_SUPPORT
- if (scm_trans && (port == def_outp || port == cur_errp))
- SCM_SYSCALL (fputs (s, scm_trans));
-#endif
-}
-
-
-
-static int scm_lfwrite SCM_P ((char *ptr, scm_sizet size, scm_sizet nitems, SCM port));
-
-static int
-scm_lfwrite (ptr, size, nitems, port)
- char *ptr;
- scm_sizet size;
- scm_sizet nitems;
- SCM port;
-{
- int ret;
- scm_sizet i = SCM_PTOBNUM (port);
- SCM_SYSCALL (ret = (scm_ptobs[i].fwrite(ptr, size, nitems, SCM_STREAM (port))));
-#ifdef TRANSCRIPT_SUPPORT
- if (scm_trans && (port == def_outp || port == cur_errp))
- SCM_SYSCALL (fwrite (ptr, size, nitems, scm_trans));
-#endif
- return ret;
-}
-
-
-
-
-
-void
-scm_gen_putc (c, port)
- int c;
- SCM port;
-{
- switch (SCM_PORT_REPRESENTATION (port))
- {
- case scm_regular_port:
- {
- /* Nothing good to do with extended chars here...
- * just truncate them.
- */
- scm_putc ((unsigned char)c, port);
- break;
- }
-
- case scm_mb_port:
- {
- char buf[256];
- int len;
-
- SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_MAKICHR (c),
- "huge translation", "scm_gen_putc");
-
- len = xwctomb (buf, c);
-
- SCM_ASSERT ((len >= 0), SCM_MAKICHR (c), "bogus character", "scm_gen_putc");
-
- if (len == 0)
- scm_putc (0, port);
- else
- {
- int x;
- for (x = 0; x < len; ++x)
- scm_putc (buf[x], port);
- }
- break;
- }
-
- case scm_wchar_port:
- {
- scm_putc (((unsigned char)(c >> 8) & 0xff), port);
- scm_putc ((unsigned char)(c & 0xff), port);
- break;
- }
- }
-}
-
-
-
-
-
-
-void
-scm_gen_puts (rep, str_data, port)
- enum scm_string_representation_type rep;
- char *str_data;
- SCM port;
-{
- switch (rep)
- {
-
- case scm_regular_string:
- switch (SCM_PORT_REPRESENTATION (port))
- {
- case scm_regular_port:
- case scm_mb_port:
- scm_puts (str_data, port);
- return;
- case scm_wchar_port:
- {
- while (*str_data)
- {
- scm_putc (0, port);
- scm_putc (*str_data, port);
- ++str_data;
- }
- return;
- }
- }
-
- case scm_mb_string:
- switch (SCM_PORT_REPRESENTATION (port))
- {
- case scm_regular_port:
- case scm_mb_port:
- scm_puts (str_data, port);
- return;
- case scm_wchar_port:
- {
- xwchar_t output;
- int len;
- int size;
-
- size = strlen (str_data);
- while (size)
- {
- len = xmbtowc (&output, str_data, size);
- SCM_ASSERT ((len > 0), SCM_MAKINUM (*str_data), "bogus character", "scm_gen_puts");
- scm_putc ((output >> 8) & 0xff, port);
- scm_putc (output & 0xff, port);
- size -= len;
- str_data += len;
- }
- return;
- }
- }
-
- case scm_wchar_string:
- {
- xwchar_t * wstr_data;
-
- wstr_data = (xwchar_t *) str_data;
- switch (SCM_PORT_REPRESENTATION (port))
- {
- case scm_regular_port:
- while (*wstr_data)
- {
- scm_putc ((unsigned char) *wstr_data, port);
- ++wstr_data;
- }
- return;
-
- case scm_mb_port:
- {
- char buf[256];
- SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F,
- "huge translation", "scm_gen_puts");
-
- while (*wstr_data)
- {
- int len;
-
- len = xwctomb (buf, *wstr_data);
-
- SCM_ASSERT ((len > 0), SCM_MAKINUM (*wstr_data), "bogus character", "scm_gen_puts");
-
- {
- int x;
- for (x = 0; x < len; ++x)
- scm_putc (buf[x], port);
- }
- ++wstr_data;
- }
- return;
- }
-
- case scm_wchar_port:
- {
- int len;
- for (len = 0; wstr_data[len]; ++len)
- ;
- scm_lfwrite (str_data, sizeof (xwchar_t), len, port);
- return;
- }
- }
- }
- }
-}
-
-
-
-
-
-void
-scm_gen_write (rep, str_data, nitems, port)
- enum scm_string_representation_type rep;
- char *str_data;
- scm_sizet nitems;
- SCM port;
-{
- /* is nitems bytes or characters in the mb_string case? */
-
- switch (rep)
- {
- case scm_regular_string:
- switch (SCM_PORT_REPRESENTATION (port))
- {
- case scm_regular_port:
- case scm_mb_port:
- scm_lfwrite (str_data, 1, nitems, port);
- return;
- case scm_wchar_port:
- {
- while (nitems)
- {
- scm_putc (0, port);
- scm_putc (*str_data, port);
- ++str_data;
- --nitems;
- }
- return;
- }
- }
-
- case scm_mb_string:
- switch (SCM_PORT_REPRESENTATION (port))
- {
- case scm_regular_port:
- case scm_mb_port:
- scm_lfwrite (str_data, 1, nitems, port);
- return;
-
- case scm_wchar_port:
- {
- xwchar_t output;
- int len;
-
- while (nitems)
- {
- len = xmbtowc (&output, str_data, nitems);
- SCM_ASSERT ((len > 0), SCM_MAKINUM (*str_data), "bogus character", "scm_gen_puts");
- scm_putc ((output >> 8) & 0xff, port);
- scm_putc (output & 0xff, port);
- nitems -= len;
- str_data += len;
- }
- return;
- }
- }
-
- case scm_wchar_string:
- {
- xwchar_t * wstr_data;
-
- wstr_data = (xwchar_t *) str_data;
- switch (SCM_PORT_REPRESENTATION (port))
- {
- case scm_regular_port:
- while (nitems)
- {
- scm_putc ((unsigned char) *wstr_data, port);
- ++wstr_data;
- --nitems;
- }
- return;
-
- case scm_mb_port:
- {
- char buf[256];
- SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F,
- "huge translation", "scm_gen_puts");
-
- while (nitems)
- {
- int len;
-
- len = xwctomb (buf, *wstr_data);
-
- SCM_ASSERT ((len > 0), SCM_MAKINUM (*wstr_data), "bogus character", "scm_gen_puts");
-
- {
- int x;
- for (x = 0; x < len; ++x)
- scm_putc (buf[x], port);
- }
- ++wstr_data;
- --nitems;
- }
- return;
- }
-
- case scm_wchar_port:
- {
- scm_lfwrite (str_data, sizeof (xwchar_t), nitems, port);
- return;
- }
- }
- }
- }
-}
-
-
-
-
-
-static int scm_getc SCM_P ((SCM port));
-
-static int
-scm_getc (port)
- SCM port;
-{
- SCM f;
- int c;
- scm_sizet i;
-
- f = SCM_STREAM (port);
- i = SCM_PTOBNUM (port);
- SCM_SYSCALL (c = (scm_ptobs[i].fgetc) (f));
- return c;
-}
-
-
-int
-scm_gen_getc (port)
- SCM port;
-{
- int c;
-
- /* One char may be stored in the high bits of (car port) orre@nada.kth.se. */
- if (SCM_CRDYP (port))
- {
- c = SCM_CGETUN (port);
- SCM_CLRDY (port); /* Clear ungetted char */
-
- return_c:
- if (c == '\n')
- {
- SCM_INCLINE (port);
- }
- else if (c == '\t')
- {
- SCM_TABCOL (port);
- }
- else
- {
- SCM_INCCOL (port);
- }
- return c;
- }
-
-
- switch (SCM_PORT_REPRESENTATION (port))
- {
- case scm_regular_port:
- c = scm_getc (port);
- goto return_c;
-
- case scm_mb_port:
- {
- int x;
- unsigned char buf[256];
-
- SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F,
- "huge translation", "scm_gen_puts");
-
- x = 0;
- while (1)
- {
- xwchar_t out;
- c = scm_getc (port);
-
- if (c == EOF)
- return EOF;
-
- buf[x] = c;
-
- if (xmbtowc (&out, buf, x + 1) > 0)
- {
- c = out;
- goto return_c;
- }
-
- SCM_ASSERT (x < sizeof (buf), SCM_BOOL_F,
- "huge translation", "scm_gen_getc");
- ++x;
- }
- }
-
-
- case scm_wchar_port:
- {
- int hi;
- int lo;
- hi = scm_getc (port);
- lo = (hi == EOF
- ? EOF
- : scm_getc (port));
- c = ((hi == EOF)
- ? EOF
- : ((hi << 8) | lo));
- goto return_c;
- }
-
-
- default:
- return EOF;
- }
-}
-
-
-void
-scm_gen_ungetc (c, port)
- int c;
- SCM port;
-{
-/* SCM_ASSERT(!SCM_CRDYP(port), port, SCM_ARG2, "too many scm_gen_ungetc");*/
- SCM_CUNGET (c, port);
- if (c == '\n')
- {
- /* What should col be in this case?
- * We'll leave it at -1.
- */
- SCM_LINUM (port) -= 1;
- }
- else
- SCM_COL(port) -= 1;
-}
-
-
diff --git a/libguile/genio.h b/libguile/genio.h
deleted file mode 100644
index 78d17fac5..000000000
--- a/libguile/genio.h
+++ /dev/null
@@ -1,59 +0,0 @@
-/* classes: h_files */
-
-#ifndef GENIOH
-#define GENIOH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-extern void scm_gen_putc SCM_P ((int c, SCM port));
-extern void scm_gen_puts SCM_P ((enum scm_string_representation_type rep,
- char *str_data,
- SCM port));
-extern void scm_gen_write SCM_P ((enum scm_string_representation_type rep, char *str_data, scm_sizet nitems, SCM port));
-extern int scm_gen_getc SCM_P ((SCM port));
-extern void scm_gen_ungetc SCM_P ((int c, SCM port));
-
-#endif /* GENIOH */
diff --git a/libguile/gscm.c b/libguile/gscm.c
deleted file mode 100644
index daf172730..000000000
--- a/libguile/gscm.c
+++ /dev/null
@@ -1,594 +0,0 @@
-/* Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-
-
-
-#include <stdio.h>
-#include <sys/param.h>
-#include "gscm.h"
-#include "_scm.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-
-
-extern char *getenv ();
-
-
-/* {Top Level Evaluation}
- *
- * Top level evaluation has to establish a dynamic root context,
- * enable Scheme signal handlers, and catch global escapes (errors, quits,
- * aborts, restarts, and execs) from the interpreter.
- */
-
-
-/* {Printing Objects to Strings}
- */
-
-
-static GSCM_status gscm_portprint_obj SCM_P ((SCM port, SCM obj));
-
-static GSCM_status
-gscm_portprint_obj (port, obj)
- SCM port;
- SCM obj;
-{
- scm_prin1 (obj, port, 1);
- return GSCM_OK;
-}
-
-
-struct seval_str_frame
-{
- GSCM_status status;
- SCM * answer;
- GSCM_top_level top;
- char * str;
-};
-
-
-static void _seval_str_fn SCM_P ((void * vframe));
-
-static void
-_seval_str_fn (vframe)
- void * vframe;
-{
- struct seval_str_frame * frame;
- frame = (struct seval_str_frame *)vframe;
- frame->status = gscm_seval_str (frame->answer, frame->top, frame->str);
-}
-
-
-
-
-static GSCM_status gscm_strprint_obj SCM_P ((SCM * answer, SCM obj));
-
-static GSCM_status
-gscm_strprint_obj (answer, obj)
- SCM * answer;
- SCM obj;
-{
- SCM str;
- SCM port;
- GSCM_status stat;
- str = scm_makstr (64, 0);
- port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "gscm_strprint_obj");
- stat = gscm_portprint_obj (port, obj);
- if (stat == GSCM_OK)
- *answer = str;
- else
- *answer = SCM_BOOL_F;
- return stat;
-}
-
-
-static GSCM_status gscm_cstr SCM_P ((char ** answer, SCM obj));
-
-static GSCM_status
-gscm_cstr (answer, obj)
- char ** answer;
- SCM obj;
-{
- GSCM_status stat;
-
- *answer = (char *)malloc (SCM_LENGTH (obj));
- stat = GSCM_OK;
- if (!*answer)
- stat = GSCM_OUT_OF_MEM;
- else
- memcpy (*answer, SCM_CHARS (obj), SCM_LENGTH (obj));
- return stat;
-}
-
-
-/* {Invoking The Interpreter}
- */
-
-
-static SCM gscm_silent_repl SCM_P ((SCM env));
-
-static SCM
-gscm_silent_repl (env)
- SCM env;
-{
- SCM source;
- SCM answer;
- answer = SCM_UNSPECIFIED;
- while ((source = scm_read (SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED)) != SCM_EOF_VAL)
- answer = scm_eval_x (source);
- return answer;
-}
-
-
-#ifdef _UNICOS
-typedef int setjmp_type;
-#else
-typedef long setjmp_type;
-#endif
-
-
-static GSCM_status _eval_port SCM_P ((SCM * answer, GSCM_top_level toplvl, SCM port, int printp));
-
-static GSCM_status
-_eval_port (answer, toplvl, port, printp)
- SCM * answer;
- GSCM_top_level toplvl;
- SCM port;
- int printp;
-{
- SCM saved_inp;
- GSCM_status status;
- setjmp_type i;
- static int deja_vu = 0;
- SCM ignored;
-
- if (deja_vu)
- return GSCM_ILLEGALLY_REENTERED;
-
- ++deja_vu;
- /* Take over signal handlers for all the interesting signals.
- */
- scm_init_signals ();
-
-
- /* Default return values:
- */
- if (!answer)
- answer = &ignored;
- status = GSCM_OK;
- *answer = SCM_BOOL_F;
-
- /* Perform evalutation under a new dynamic root.
- *
- */
- SCM_BASE (scm_rootcont) = (SCM_STACKITEM *) & i;
-#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
-#endif
- saved_inp = scm_cur_inp;
- i = setjmp (SCM_JMPBUF (scm_rootcont));
-#ifdef STACK_CHECKING
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-#endif
- if (!i)
- {
- scm_gc_heap_lock = 0;
- scm_ints_disabled = 0;
- /* need to close loading files here. */
- scm_cur_inp = port;
- {
- SCM top_env;
- top_env = SCM_EOL;
- *answer = gscm_silent_repl (top_env);
- }
- scm_cur_inp = saved_inp;
- if (printp)
- status = gscm_strprint_obj (answer, *answer);
- }
- else
- {
- scm_cur_inp = saved_inp;
- *answer = scm_exitval;
- if (printp)
- gscm_strprint_obj (answer, *answer);
- status = GSCM_ERROR;
- }
-
- scm_gc_heap_lock = 1;
- scm_ints_disabled = 1;
- scm_restore_signals ();
- --deja_vu;
- return status;
-}
-
-
-static GSCM_status seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str));
-
-static GSCM_status
-seval_str (answer, toplvl, str)
- SCM *answer;
- GSCM_top_level toplvl;
- char * str;
-{
- SCM scheme_str;
- SCM port;
- GSCM_status status;
-
- scheme_str = scm_makfromstr (str, strlen (str), 0);
- port = scm_mkstrport (SCM_MAKINUM (0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_seval_str");
- status = _eval_port (answer, toplvl, port, 0);
- return status;
-}
-
-
-
-GSCM_status
-gscm_seval_str (answer, toplvl, str)
- SCM *answer;
- GSCM_top_level toplvl;
- char * str;
-{
- SCM_STACKITEM i;
- GSCM_status status;
- scm_stack_base = &i;
- status = seval_str (answer, toplvl, str);
- scm_stack_base = 0;
- return status;
-}
-
-
-void
-format_load_command (buf, file_name)
- char * buf;
- char *file_name;
-{
- char quoted_name[MAXPATHLEN + 1];
- int source;
- int dest;
-
- for (source = dest = 0; file_name[source]; ++source)
- {
- if (file_name[source] == '"')
- quoted_name[dest++] = '\\';
- quoted_name[dest++] = file_name[source];
- }
- quoted_name[dest] = 0;
- sprintf (buf, "(%%try-load \"%s\")", quoted_name);
-}
-
-
-GSCM_status
-gscm_seval_file (answer, toplvl, file_name)
- SCM *answer;
- GSCM_top_level toplvl;
- char * file_name;
-{
- char command[MAXPATHLEN * 3];
- format_load_command (command, file_name);
- return gscm_seval_str (answer, toplvl, command);
-}
-
-
-
-static GSCM_status eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str));
-
-static GSCM_status
-eval_str (answer, toplvl, str)
- char ** answer;
- GSCM_top_level toplvl;
- char * str;
-{
- SCM sanswer;
- SCM scheme_str;
- SCM port;
- GSCM_status status;
-
- scheme_str = scm_makfromstr (str, strlen (str), 0);
- port = scm_mkstrport (SCM_MAKINUM(0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_eval_str");
- status = _eval_port (&sanswer, toplvl, port, 1);
- if (answer)
- {
- if (status == GSCM_OK)
- status = gscm_cstr (answer, sanswer);
- else
- *answer = 0;
- }
- return status;
-}
-
-
-
-GSCM_status
-gscm_eval_str (answer, toplvl, str)
- char ** answer;
- GSCM_top_level toplvl;
- char * str;
-{
- SCM_STACKITEM i;
- GSCM_status status;
- scm_stack_base = &i;
- status = eval_str (answer, toplvl, str);
- scm_stack_base = 0;
- return status;
-}
-
-
-
-GSCM_status
-gscm_eval_file (answer, toplvl, file_name)
- char ** answer;
- GSCM_top_level toplvl;
- char * file_name;
-{
- char command[MAXPATHLEN * 3];
- format_load_command (command, file_name);
- return gscm_eval_str (answer, toplvl, command);
-}
-
-
-
-
-/* {Error Messages}
- */
-
-
-#ifdef __GNUC__
-# define AT(X) [X] =
-#else
-# define AT(X)
-#endif
-
-static char * gscm_error_msgs[] =
-{
- AT(GSCM_OK) "No error.",
- AT(GSCM_ERROR) "ERROR in init file.",
- AT(GSCM_ILLEGALLY_REENTERED) "Gscm function was illegally reentered.",
- AT(GSCM_OUT_OF_MEM) "Out of memory.",
- AT(GSCM_ERROR_OPENING_FILE) "Error opening file.",
- AT(GSCM_ERROR_OPENING_INIT_FILE) "Error opening init file."
-};
-
-
-char *
-gscm_error_msg (n)
- int n;
-{
- if ((n < 0) || (n > (sizeof (gscm_error_msgs) / sizeof (char *))))
- return "Unrecognized error.";
- else
- return gscm_error_msgs[n];
-}
-
-
-
-/* {Defining New Procedures}
- */
-
-
-SCM
-gscm_make_subr (fn, req, opt, varp, doc)
- SCM (*fn)();
- int req;
- int opt;
- int varp;
- char * doc;
-{
- return scm_make_gsubr ("*anonymous*", req, opt, varp, fn);
-}
-
-
-int
-gscm_2_char (c)
- SCM c;
-{
- SCM_ASSERT (SCM_ICHRP (c), c, SCM_ARG1, "gscm_2_char");
- return SCM_ICHR (c);
-}
-
-
-
-
-void
-gscm_2_str (out, len_out, objp)
- char ** out;
- int * len_out;
- SCM * objp;
-{
- SCM_ASSERT (SCM_NIMP (*objp) && SCM_STRINGP (*objp), *objp, SCM_ARG3, "gscm_2_str");
- if (out)
- *out = SCM_CHARS (*objp);
- if (len_out)
- *len_out = SCM_LENGTH (*objp);
-}
-
-
-
-void
-gscm_error (message, args)
- char * message;
- SCM args;
-{
- SCM errsym;
- SCM str;
-
- errsym = SCM_CAR (scm_intern ("error", 5));
- str = scm_makfrom0str (message);
- scm_throw (errsym, scm_cons (str, args));
-}
-
-
-
-GSCM_status
-gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd)
- int argc;
- char ** argv;
- FILE * in;
- FILE * out;
- FILE * err;
- GSCM_status (*initfn)();
- char * initfile;
- char * initcmd;
-{
- SCM_STACKITEM i;
- GSCM_status status;
- GSCM_top_level top;
-
- scm_ports_prehistory ();
- scm_smob_prehistory ();
- scm_tables_prehistory ();
- scm_init_storage (0);
- scm_start_stack (&i, in, out, err);
- scm_init_gsubr ();
- scm_init_curry ();
- scm_init_feature ();
-/* scm_init_debug (); */
- scm_init_alist ();
- scm_init_append ();
- scm_init_arbiters ();
- scm_init_async ();
- scm_init_boolean ();
- scm_init_chars ();
- scm_init_continuations ();
- scm_init_dynwind ();
- scm_init_eq ();
- scm_init_error ();
- scm_init_fports ();
- scm_init_files ();
- scm_init_gc ();
- scm_init_hash ();
- scm_init_hashtab ();
- scm_init_kw ();
- scm_init_list ();
- scm_init_lvectors ();
- scm_init_numbers ();
- scm_init_pairs ();
- scm_init_ports ();
- scm_init_procs ();
- scm_init_procprop ();
- scm_init_scmsigs ();
- scm_init_stackchk ();
- scm_init_strports ();
- scm_init_struct ();
- scm_init_symbols ();
- scm_init_load ();
- scm_init_print ();
- scm_init_read ();
- scm_init_sequences ();
- scm_init_stime ();
- scm_init_strings ();
- scm_init_strorder ();
- scm_init_mbstrings ();
- scm_init_strop ();
- scm_init_throw ();
- scm_init_variable ();
- scm_init_vectors ();
- scm_init_version ();
- scm_init_weaks ();
- scm_init_vports ();
- scm_init_eval ();
- scm_init_ramap ();
- scm_init_unif ();
- scm_init_simpos ();
- scm_init_elisp ();
- scm_init_mallocs ();
- scm_init_cnsvobj ();
- scm_init_guile ();
- initfn ();
-
- /* Save the argument list to be the return value of (program-arguments).
- */
- scm_progargs = scm_makfromstrs (argc, argv);
-
- scm_gc_heap_lock = 0;
- errno = 0;
- scm_ints_disabled = 1;
-
-/* init_basic (); */
-
-/* init_init(); */
-
- if (initfile == NULL)
- {
- initfile = getenv ("GUILE_INIT_PATH");
- if (initfile == NULL)
- initfile = SCM_IMPLINIT;
- }
-
- if (initfile == NULL)
- {
- status = GSCM_OK;
- }
- else
- {
- SCM answer;
-
- status = gscm_seval_file (&answer, -1, initfile);
- if ((status == GSCM_OK) && (answer == SCM_BOOL_F))
- status = GSCM_ERROR_OPENING_INIT_FILE;
- }
-
- top = SCM_EOL;
-
- if (status == GSCM_OK)
- {
- scm_sysintern ("*stdin*", scm_cur_inp);
- status = gscm_seval_str (0, top, initcmd);
- }
- return status;
-}
-
-
-
-
-void
-scm_init_guile ()
-{
-#include "gscm.x"
-}
-
diff --git a/libguile/gscm.h b/libguile/gscm.h
deleted file mode 100644
index 7e0554e5e..000000000
--- a/libguile/gscm.h
+++ /dev/null
@@ -1,281 +0,0 @@
-/* classes: h_files */
-
-#ifndef GSCMH
-#define GSCMH
-
-/* Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile.h"
-
-
-/* {Locking Out Async Execution (including async GC) and Non-Local Exits}
- */
-
-#define GSCM_DEFER_INTS SCM_DEFER_INTS
-#define GSCM_ALLOW_INTS SCM_ALLOW_INTS
-
-
-/* {Common Constants}
- */
-
-#define GSCM_EOL SCM_EOL
-#define GSCM_FALSE SCM_BOOL_F
-#define GSCM_TRUE SCM_BOOL_T
-
-#define GSCM_EOL_MARKER SCM_UNDEFINED
-#define GSCM_NOT_PASSED SCM_UNDEFINED
-#define GSCM_UNSPECIFIED SCM_UNSPECIFIED
-
-
-/* {Booleans}
- */
-
-#define gscm_bool(CBOOL) ((CBOOL) ? SCM_BOOL_T : SCM_BOOL_F)
-#define gscm_2_bool(BOOL) (((BOOL) == SCM_BOOL_F) ? 0 : 1)
-
-
-/* {Numbers}
- */
-
-#define gscm_ulong scm_ulong2num
-#define gscm_long scm_long2num
-#define gscm_double(X) scm_makdbl ((X), 0.0)
-
-#define gscm_2_ulong(OBJ) scm_num2ulong((OBJ), (char *)SCM_ARG1, "gscm_2_ulong")
-#define gscm_2_long(OBJ) scm_num2long((OBJ), (char *)SCM_ARG1, "gscm_2_long")
-#define gscm_2_double(OBJ) scm_num2dbl((OBJ), "gscm_2_double")
-
-
-/* {Characters}
- */
-
-#define gscm_char(C) SCM_MAKICHR(C)
-/* extern int gscm_2_char P((SCM)); */
-
-
-/* {Strings}
- */
-
-#define gscm_str(SRC, LEN) scm_makfromstr (SRC, LEN, 0)
-#define gscm_str0 scm_makfrom0str
-
-
-
-/* {Pairs and Lists}
- */
-
-#define gscm_cons scm_cons
-#define gscm_list scm_listify
-#define gscm_ilength scm_ilength
-
-
-#define gscm_set_car(OBJ, VAL) \
- ((SCM_NIMP(OBJ) && SCM_CONSP(OBJ)) \
- ? (SCM_CAR(OBJ) = VAL) \
- : scm_wta ((OBJ), (char *)SCM_ARG1, "set-car!"))
-
-#define gscm_set_cdr(OBJ, VAL) \
- ((SCM_NIMP(OBJ) && SCM_CONSP(OBJ)) \
- ? (SCM_CDR(OBJ) = VAL) \
- : scm_wta ((OBJ), (char *)SCM_ARG1, "set-cdr!"))
-
-
-#define GSCM_SAFE_CAR(X) ((SCM_NIMP(X) && SCM_CONSP(X)) \
- ? SCM_CAR(X) \
- : scm_wta ((X), (char *)SCM_ARG1, "car"))
-
-#define GSCM_SAFE_CDR(X) ((SCM_NIMP(X) && SCM_CONSP(X)) \
- ? SCM_CDR(X) \
- : scm_wta ((X), (char *)SCM_ARG1, "cdr"))
-
-#define gscm_car(OBJ) GSCM_SAFE_CAR (OBJ)
-#define gscm_cdr(OBJ) GSCM_SAFE_CDR (OBJ)
-
-#define gscm_caar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))
-#define gscm_cdar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))
-#define gscm_cadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))
-#define gscm_cddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))
-
-#define gscm_caaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))
-#define gscm_cdaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ)))
-#define gscm_cadar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))
-#define gscm_cddar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ)))
-#define gscm_caadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))
-#define gscm_cdadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ)))
-#define gscm_caddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))
-#define gscm_cdddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ)))
-
-#define gscm_caaaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))))
-#define gscm_cdaaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))))
-#define gscm_cadaar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))))
-#define gscm_cddaar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (OBJ))))
-#define gscm_caadar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))))
-#define gscm_cdadar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))))
-#define gscm_caddar(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))))
-#define gscm_cdddar(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (OBJ))))
-#define gscm_caaadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))))
-#define gscm_cdaadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))))
-#define gscm_cadadr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))))
-#define gscm_cddadr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (OBJ))))
-#define gscm_caaddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))))
-#define gscm_cdaddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))))
-#define gscm_cadddr(OBJ) GSCM_SAFE_CAR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))))
-#define gscm_cddddr(OBJ) GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (GSCM_SAFE_CDR (OBJ))))
-
-
-/* {Symbols}
- */
-
-#define gscm_symbol(STR, LEN) SCM_CAR(scm_intern (STR, LEN))
-#define gscm_tmp_symbol(STR, LEN) SCM_CAR(scm_intern_obarray (STR, LEN, SCM_BOOL_F))
-
-
-/* {Vectors}
- */
-
-#define gscm_vector(N, FILL) scm_make_vector (SCM_MAKINUM(N), (FILL), SCM_UNDEFINED)
-#define gscm_vref(V, I) scm_vector_ref ((V), SCM_MAKINUM(I))
-#define gscm_vset(V, I, VAL) scm_vector_set_x ((V), SCM_MAKINUM(I), (VAL))
-
-
-/* {Procedures}
- */
-
-/* extern SCM gscm_make_subr P((SCM (*fn)(), int req, int opt, int varp, char * doc)); */
-/* extern SCM gscm_curry P((SCM procedure, SCM first_arg)); */
-
-#define gscm_apply(PROC, ARGS) scm_apply ((PROC), (ARGS), SCM_EOL)
-
-
-
-/* {Non-local Exits}
- */
-
-
-#define gscm_catch(T, TH, H) scm_catch ((T), (TH), (H))
-#define gscm_throw(T, V) scm_throw ((T), (V))
-#define gscm_dynamic_wind(E, T, L) scm_dynwind ((E), (T), (L))
-/* extern void gscm_error P((char * message, SCM args)); */
-
-
-/* {I/O}
- */
-
-#define gscm_print_obj scm_prin1
-#define gscm_putc scm_putc
-#define gscm_puts scm_puts
-#define gscm_fwrite scm_fwrite
-#define gscm_flush scm_flush
-
-extern char * gscm_last_attempted_init_file;
-
-/* {Equivalence}
- */
-
-
-#define gscm_is_eq(OBJ) (SCM_BOOL_F != scm_eq (OBJ))
-#define gscm_is_eqv(OBJ) (SCM_BOOL_F != scm_eqv (OBJ))
-#define gscm_is_equal(OBJ) (SCM_BOOL_F != scm_equal_p (OBJ))
-
-
-/* {Procedure Properties}
- */
-
-#define gscm_procedure_properties scm_procedure_properties
-#define gscm_set_procedure_properties_x scm_set_procedure_properties_x
-#define gscm_procedure_property scm_procedure_property
-#define gscm_set_procedure_property_x scm_set_procedure_property_x
-
-
-/* {Generic Length Procedure}
- */
-
-#define gscm_obj_length scm_obj_length
-
-
-/* {Proc Declaration Macro}
- */
-#ifndef GSCM_MAGIC_SNARFER
-#define GSCM_PROC(RANAME, CFN, STR, REQ, OPT, VAR) \
- static char RANAME[]=STR;
-#else
-#define GSCM_PROC(RANAME, CFN, STR, REQ, OPT, VAR) \
-%%% gscm_define_procedure (RANAME, CFN, REQ, OPT, VAR, "")
-#endif
-
-#define gscm_define_procedure(NAME, FN, REQ, OPT, VARP, DOC) scm_make_gsubr(name, req, opt, varp, fn)
-#define gscm_curry scm_curry
-#define gscm_define scm_sysintern
-
-
-typedef int GSCM_top_level;
-
-
-/* {Error Returns}
- */
-
-typedef int GSCM_status;
-
-#define GSCM_OK 0
-#define GSCM_ERROR 1
-#define GSCM_ILLEGALLY_REENTERED 2
-#define GSCM_OUT_OF_MEM 3
-#define GSCM_ERROR_OPENING_FILE 4
-#define GSCM_ERROR_OPENING_INIT_FILE 5
-
-
-
-extern GSCM_status gscm_seval_str SCM_P ((SCM *answer, GSCM_top_level toplvl, char * str));
-extern GSCM_status gscm_seval_file SCM_P ((SCM *answer, GSCM_top_level toplvl, char * file_name));
-extern GSCM_status gscm_eval_str SCM_P ((char ** answer, GSCM_top_level toplvl, char * str));
-extern GSCM_status gscm_eval_file SCM_P ((char ** answer, GSCM_top_level toplvl, char * file_name));
-extern GSCM_status gscm_run_scm SCM_P ((int argc, char ** argv, FILE * in, FILE * out, FILE * err, GSCM_status (*initfn)(void), char * initfile, char * initcmd));
-extern char * gscm_error_msg SCM_P ((int n));
-extern SCM gscm_make_subr SCM_P ((SCM (*fn)(), int req, int opt, int varp, char * doc));
-extern int gscm_2_char SCM_P ((SCM c));
-extern void gscm_2_str SCM_P ((char ** out, int * len_out, SCM * objp));
-extern void gscm_error SCM_P ((char * message, SCM args));
-extern void scm_init_guile SCM_P ((void));
-
-#endif /* GSCMH */
-
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
deleted file mode 100644
index b69a6c497..000000000
--- a/libguile/gsubr.c
+++ /dev/null
@@ -1,193 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "genio.h"
-#include "procprop.h"
-
-#include "gsubr.h"
-
-/*
- * gsubr.c
- * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
- * and rest arguments.
- */
-
-#include "gsubr.h"
-
-#define GSUBR_TEST 1
-
-#define GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
-#define GSUBR_REQ(x) ((int)(x)&0xf)
-#define GSUBR_OPT(x) (((int)(x)&0xf0)>>4)
-#define GSUBR_REST(x) ((int)(x)>>8)
-
-#define GSUBR_MAX 10
-#define GSUBR_TYPE(cclo) (SCM_VELTS(cclo)[1])
-#define GSUBR_PROC(cclo) (SCM_VELTS(cclo)[2])
-
-SCM scm_i_name;
-static SCM f_gsubr_apply;
-
-SCM
-scm_make_gsubr(name, req, opt, rst, fcn)
- char *name;
- int req;
- int opt;
- int rst;
- SCM (*fcn)();
-{
- switch GSUBR_MAKTYPE(req, opt, rst) {
- case GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, scm_tc7_subr_0, fcn);
- case GSUBR_MAKTYPE(1, 0, 0): return scm_make_subr(name, scm_tc7_subr_1, fcn);
- case GSUBR_MAKTYPE(0, 1, 0): return scm_make_subr(name, scm_tc7_subr_1o, fcn);
- case GSUBR_MAKTYPE(1, 1, 0): return scm_make_subr(name, scm_tc7_subr_2o, fcn);
- case GSUBR_MAKTYPE(2, 0, 0): return scm_make_subr(name, scm_tc7_subr_2, fcn);
- case GSUBR_MAKTYPE(3, 0, 0): return scm_make_subr(name, scm_tc7_subr_3, fcn);
- case GSUBR_MAKTYPE(0, 0, 1): return scm_make_subr(name, scm_tc7_lsubr, fcn);
- case GSUBR_MAKTYPE(2, 0, 1): return scm_make_subr(name, scm_tc7_lsubr_2, fcn);
- default:
- {
- SCM symcell = scm_sysintern(name, SCM_UNDEFINED);
- SCM z, cclo = scm_makcclo(f_gsubr_apply, 3L);
- long tmp = ((((SCM_CELLPTR)(SCM_CAR(symcell)))-scm_heap_org)<<8);
- if (GSUBR_MAX < req + opt + rst) {
- fputs("ERROR in scm_make_gsubr: too many args\n", stderr);
- exit (1);
- }
- if ((tmp>>8) != ((SCM_CELLPTR)(SCM_CAR(symcell))-scm_heap_org))
- tmp = 0;
- SCM_NEWCELL(z);
- SCM_SUBRF(z) = fcn;
- SCM_SETCAR (z, tmp + scm_tc7_subr_0);
- GSUBR_PROC(cclo) = z;
- GSUBR_TYPE(cclo) = SCM_MAKINUM(GSUBR_MAKTYPE(req, opt, rst));
- SCM_SETCDR (symcell, cclo);
-#ifdef DEBUG_EXTENSIONS
- if (SCM_REC_PROCNAMES_P)
- scm_set_procedure_property_x (cclo, scm_i_name, SCM_CAR (symcell));
-#endif
- return cclo;
- }
- }
-}
-
-
-SCM_PROC(s_gsubr_apply, "gsubr-apply", 0, 0, 1, scm_gsubr_apply);
-
-SCM
-scm_gsubr_apply(args)
- SCM args;
-{
- SCM self = SCM_CAR(args);
- SCM (*fcn)() = SCM_SUBRF(GSUBR_PROC(self));
- SCM v[10]; /* must agree with greatest supported arity */
- int typ = SCM_INUM(GSUBR_TYPE(self));
- int i, n = GSUBR_REQ(typ) + GSUBR_OPT(typ) + GSUBR_REST(typ);
- args = SCM_CDR(args);
- for (i = 0; i < GSUBR_REQ(typ); i++) {
-#ifndef RECKLESS
- if (SCM_IMP(args))
- scm_wrong_num_args (SCM_SNAME(GSUBR_PROC(self)));
-#endif
- v[i] = SCM_CAR(args);
- args = SCM_CDR(args);
- }
- for (; i < GSUBR_REQ(typ) + GSUBR_OPT(typ); i++) {
- if (SCM_NIMP(args)) {
- v[i] = SCM_CAR(args);
- args = SCM_CDR(args);
- }
- else
- v[i] = SCM_UNDEFINED;
- }
- if (GSUBR_REST(typ))
- v[i] = args;
- switch (n) {
- default: scm_wta(self, "internal programming error", s_gsubr_apply);
- case 2: return (*fcn)(v[0], v[1]);
- case 3: return (*fcn)(v[0], v[1], v[2]);
- case 4: return (*fcn)(v[0], v[1], v[2], v[3]);
- case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]);
- case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]);
- case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]);
- case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]);
- case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]);
- case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]);
- }
-}
-
-
-#ifdef GSUBR_TEST
-/* A silly example, taking 2 required args, 1 optional, and
- a scm_list of rest args
- */
-SCM
-gsubr_21l(req1, req2, opt, rst)
- SCM req1, req2, opt, rst;
-{
- scm_gen_puts (scm_regular_string, "gsubr-2-1-l:\n req1: ", scm_cur_outp);
- scm_display(req1, scm_cur_outp);
- scm_gen_puts (scm_regular_string, "\n req2: ", scm_cur_outp);
- scm_display(req2, scm_cur_outp);
- scm_gen_puts (scm_regular_string, "\n opt: ", scm_cur_outp);
- scm_display(opt, scm_cur_outp);
- scm_gen_puts (scm_regular_string, "\n rest: ", scm_cur_outp);
- scm_display(rst, scm_cur_outp);
- scm_newline(scm_cur_outp);
- return SCM_UNSPECIFIED;
-}
-#endif
-
-
-
-void
-scm_init_gsubr()
-{
- f_gsubr_apply = scm_make_subr(s_gsubr_apply, scm_tc7_lsubr, scm_gsubr_apply);
- scm_i_name = SCM_CAR (scm_sysintern ("name", SCM_UNDEFINED));
- scm_permanent_object (scm_i_name);
-#ifdef GSUBR_TEST
- scm_make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
-#endif
-}
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
deleted file mode 100644
index 7eb34ce02..000000000
--- a/libguile/gsubr.h
+++ /dev/null
@@ -1,55 +0,0 @@
-/* classes: h_files */
-
-#ifndef GSUBRH
-#define GSUBRH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-extern SCM scm_make_gsubr SCM_P ((char *name, int req, int opt, int rst, SCM (*fcn)()));
-extern SCM scm_gsubr_apply SCM_P ((SCM args));
-extern void scm_init_gsubr SCM_P ((void));
-
-#endif /* GSUBRH */
diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in
deleted file mode 100644
index e9254cdbc..000000000
--- a/libguile/guile-snarf.in
+++ /dev/null
@@ -1,4 +0,0 @@
-#!/bin/sh
-# Extract the initialization actions for builtin things.
-
-@CPP@ -DSCM_MAGIC_SNARFER $* | grep "^%%%" | sed -e "s/^%%%//"
diff --git a/libguile/hash.c b/libguile/hash.c
deleted file mode 100644
index 3ea9f866a..000000000
--- a/libguile/hash.c
+++ /dev/null
@@ -1,222 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-
-#include "hash.h"
-
-
-#ifndef floor
-extern double floor();
-#endif
-
-
-unsigned long
-scm_hasher(obj, n, d)
- SCM obj;
- unsigned long n;
- scm_sizet d;
-{
- switch (7 & (int) obj) {
- case 2: case 6: /* SCM_INUMP(obj) */
- return SCM_INUM(obj) % n;
- case 4:
- if SCM_ICHRP(obj)
- return (unsigned)(scm_downcase(SCM_ICHR(obj))) % n;
- switch ((int) obj) {
-#ifndef SICP
- case (int) SCM_EOL: d = 256; break;
-#endif
- case (int) SCM_BOOL_T: d = 257; break;
- case (int) SCM_BOOL_F: d = 258; break;
- case (int) SCM_EOF_VAL: d = 259; break;
- default: d = 263; /* perhaps should be error */
- }
- return d % n;
- default: return 263 % n; /* perhaps should be error */
- case 0:
- switch SCM_TYP7(obj) {
- default: return 263 % n;
- case scm_tc7_smob:
- switch SCM_TYP16(obj) {
- case scm_tcs_bignums:
- bighash: return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n)));
- default: return 263 % n;
-#ifdef SCM_FLOATS
- case scm_tc16_flo:
- if SCM_REALP(obj) {
- double r = SCM_REALPART(obj);
- if (floor(r)==r) {
- obj = scm_inexact_to_exact (obj);
- if SCM_IMP(obj) return SCM_INUM(obj) % n;
- goto bighash;
- }
- }
- obj = scm_number_to_string(obj, SCM_MAKINUM(10));
-#endif
- }
- case scm_tcs_symbols:
- case scm_tc7_string:
- case scm_tc7_mb_string:
- case scm_tc7_substring:
- case scm_tc7_mb_substring:
- return scm_strhash(SCM_ROUCHARS(obj), (scm_sizet) SCM_ROLENGTH(obj), n);
- case scm_tc7_wvect:
- case scm_tc7_vector:
- {
- scm_sizet len = SCM_LENGTH(obj);
- SCM *data = SCM_VELTS(obj);
- if (len>5)
- {
- scm_sizet i = d/2;
- unsigned long h = 1;
- while (i--) h = ((h<<8) + (scm_hasher(data[h % len], n, 2))) % n;
- return h;
- }
- else
- {
- scm_sizet i = len;
- unsigned long h = (n)-1;
- while (i--) h = ((h<<8) + (scm_hasher(data[i], n, d/len))) % n;
- return h;
- }
- }
- case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar:
- if (d) return (scm_hasher(SCM_CAR(obj), n, d/2)+scm_hasher(SCM_CDR(obj), n, d/2)) % n;
- else return 1;
- case scm_tc7_port:
- return ((SCM_RDNG & SCM_CAR(obj)) ? 260 : 261) % n;
- case scm_tcs_closures: case scm_tc7_contin: case scm_tcs_subrs:
- return 262 % n;
- }
- }
-}
-
-
-
-
-
-unsigned int
-scm_ihashq (obj, n)
- SCM obj;
- unsigned int n;
-{
- return (((unsigned int) obj) >> 1) % n;
-}
-
-
-SCM_PROC(s_hashq, "hashq", 2, 0, 0, scm_hashq);
-
-SCM
-scm_hashq(obj, n)
- SCM obj;
- SCM n;
-{
- SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashq);
- return SCM_MAKINUM(scm_ihashq (obj, SCM_INUM (n)));
-}
-
-
-
-
-
-unsigned int
-scm_ihashv (obj, n)
- SCM obj;
- unsigned int n;
-{
- if (SCM_ICHRP(obj))
- return ((unsigned int)(scm_downcase(SCM_ICHR(obj)))) % n; /* downcase!?!! */
-
- if (SCM_NIMP(obj) && SCM_NUMP(obj))
- return (unsigned int) scm_hasher(obj, n, 10);
- else
- return ((unsigned int)obj) % n;
-}
-
-
-SCM_PROC(s_hashv, "hashv", 2, 0, 0, scm_hashv);
-
-SCM
-scm_hashv(obj, n)
- SCM obj;
- SCM n;
-{
- SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hashv);
- return SCM_MAKINUM(scm_ihashv (obj, SCM_INUM (n)));
-}
-
-
-
-
-
-unsigned int
-scm_ihash (obj, n)
- SCM obj;
- unsigned int n;
-{
- return (unsigned int)scm_hasher (obj, n, 10);
-}
-
-SCM_PROC(s_hash, "hash", 2, 0, 0, scm_hash);
-
-SCM
-scm_hash(obj, n)
- SCM obj;
- SCM n;
-{
- SCM_ASSERT(SCM_INUMP(n) && 0 <= n, n, SCM_ARG2, s_hash);
- return SCM_MAKINUM(scm_ihash(obj, SCM_INUM(n)));
-}
-
-
-
-
-
-void
-scm_init_hash ()
-{
-#include "hash.x"
-}
-
diff --git a/libguile/hash.h b/libguile/hash.h
deleted file mode 100644
index b9637d0c0..000000000
--- a/libguile/hash.h
+++ /dev/null
@@ -1,60 +0,0 @@
-/* classes: h_files */
-
-#ifndef HASHH
-#define HASHH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-extern unsigned long scm_hasher SCM_P ((SCM obj, unsigned long n, scm_sizet d));
-extern unsigned int scm_ihashq SCM_P ((SCM obj, unsigned int n));
-extern SCM scm_hashq SCM_P ((SCM obj, SCM n));
-extern unsigned int scm_ihashv SCM_P ((SCM obj, unsigned int n));
-extern SCM scm_hashv SCM_P ((SCM obj, SCM n));
-extern unsigned int scm_ihash SCM_P ((SCM obj, unsigned int n));
-extern SCM scm_hash SCM_P ((SCM obj, SCM n));
-extern void scm_init_hash SCM_P ((void));
-
-#endif /* HASHH */
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
deleted file mode 100644
index a3cd76499..000000000
--- a/libguile/hashtab.c
+++ /dev/null
@@ -1,540 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "alist.h"
-#include "hash.h"
-#include "eval.h"
-
-#include "hashtab.h"
-
-
-
-SCM
-scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure)
- SCM table;
- SCM obj;
- unsigned int (*hash_fn)();
- SCM (*assoc_fn)();
- void * closure;
-{
- int k;
- SCM h;
-
- SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_get_handle");
- if (SCM_LENGTH (table) == 0)
- return SCM_EOL;
- k = hash_fn (obj, SCM_LENGTH (table), closure);
- SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)),
- SCM_MAKINUM (k),
- SCM_OUTOFRANGE,
- "hash_fn_get_handle");
- h = assoc_fn (obj, SCM_VELTS (table)[k], closure);
- return h;
-}
-
-
-
-SCM
-scm_hash_fn_create_handle_x (table, obj, init, hash_fn, assoc_fn, closure)
- SCM table;
- SCM obj;
- SCM init;
- unsigned int (*hash_fn)();
- SCM (*assoc_fn)();
- void * closure;
-{
- int k;
- SCM it;
-
- SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_create_handle_x");
- if (SCM_LENGTH (table) == 0)
- return SCM_EOL;
- k = hash_fn (obj, SCM_LENGTH (table), closure);
- SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)),
- SCM_MAKINUM (k),
- SCM_OUTOFRANGE,
- "hash_fn_create_handle_x");
- SCM_REDEFER_INTS;
- it = assoc_fn (obj, SCM_VELTS (table)[k], closure);
- if (SCM_NIMP (it))
- {
- return it;
- }
- {
- SCM new_bucket;
- SCM old_bucket;
- old_bucket = SCM_VELTS (table)[k];
- new_bucket = scm_acons (obj, init, old_bucket);
- SCM_VELTS(table)[k] = new_bucket;
- SCM_REALLOW_INTS;
- return SCM_CAR (new_bucket);
- }
-}
-
-
-
-
-SCM
-scm_hash_fn_ref (table, obj, dflt, hash_fn, assoc_fn, closure)
- SCM table;
- SCM obj;
- SCM dflt;
- unsigned int (*hash_fn)();
- SCM (*assoc_fn)();
- void * closure;
-{
- SCM it;
-
- it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
- if (SCM_IMP (it))
- return dflt;
- else
- return SCM_CDR (it);
-}
-
-
-
-
-SCM
-scm_hash_fn_set_x (table, obj, val, hash_fn, assoc_fn, closure)
- SCM table;
- SCM obj;
- SCM val;
- unsigned int (*hash_fn)();
- SCM (*assoc_fn)();
- void * closure;
-{
- SCM it;
-
- it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure);
- SCM_SETCDR (it, val);
- return val;
-}
-
-
-
-
-
-SCM
-scm_hash_fn_remove_x (table, obj, hash_fn, assoc_fn, delete_fn, closure)
- SCM table;
- SCM obj;
- unsigned int (*hash_fn)();
- SCM (*assoc_fn)();
- SCM (*delete_fn)();
- void * closure;
-{
- int k;
- SCM h;
-
- SCM_ASSERT (SCM_NIMP (table) && SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x");
- if (SCM_LENGTH (table) == 0)
- return SCM_EOL;
- k = hash_fn (obj, SCM_LENGTH (table), closure);
- SCM_ASSERT ((0 <= k) && (k < SCM_LENGTH (table)),
- SCM_MAKINUM (k),
- SCM_OUTOFRANGE,
- "hash_fn_remove_x");
- h = assoc_fn (obj, SCM_VELTS (table)[k], closure);
- SCM_VELTS(table)[k] = delete_fn (h, SCM_VELTS(table)[k]);
- return h;
-}
-
-
-
-
-SCM_PROC (s_hashq_get_handle, "hashq-get-handle", 2, 0, 0, scm_hashq_get_handle);
-
-SCM
-scm_hashq_get_handle (table, obj)
- SCM table;
- SCM obj;
-{
- return scm_hash_fn_get_handle (table, obj, scm_ihashq, scm_sloppy_assq, 0);
-}
-
-
-SCM_PROC (s_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, scm_hashq_create_handle_x);
-
-SCM
-scm_hashq_create_handle_x (table, obj, init)
- SCM table;
- SCM obj;
- SCM init;
-{
- return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashq, scm_sloppy_assq, 0);
-}
-
-
-SCM_PROC (s_hashq_ref, "hashq-ref", 2, 1, 0, scm_hashq_ref);
-
-SCM
-scm_hashq_ref (table, obj, dflt)
- SCM table;
- SCM obj;
- SCM dflt;
-{
- if (dflt == SCM_UNDEFINED)
- dflt = SCM_BOOL_F;
- return scm_hash_fn_ref (table, obj, dflt, scm_ihashq, scm_sloppy_assq, 0);
-}
-
-
-
-SCM_PROC (s_hashq_set_x, "hashq-set!", 3, 0, 0, scm_hashq_set_x);
-
-SCM
-scm_hashq_set_x (table, obj, val)
- SCM table;
- SCM obj;
- SCM val;
-{
- return scm_hash_fn_set_x (table, obj, val, scm_ihashq, scm_sloppy_assq, 0);
-}
-
-
-
-SCM_PROC (s_hashq_remove_x, "hashq-remove!", 2, 0, 0, scm_hashq_remove_x);
-
-SCM
-scm_hashq_remove_x (table, obj)
- SCM table;
- SCM obj;
-{
- return scm_hash_fn_remove_x (table, obj, scm_ihashq, scm_sloppy_assq, scm_delq_x, 0);
-}
-
-
-
-
-SCM_PROC (s_hashv_get_handle, "hashv-get-handle", 2, 0, 0, scm_hashv_get_handle);
-
-SCM
-scm_hashv_get_handle (table, obj)
- SCM table;
- SCM obj;
-{
- return scm_hash_fn_get_handle (table, obj, scm_ihashv, scm_sloppy_assv, 0);
-}
-
-
-SCM_PROC (s_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, scm_hashv_create_handle_x);
-
-SCM
-scm_hashv_create_handle_x (table, obj, init)
- SCM table;
- SCM obj;
- SCM init;
-{
- return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashv, scm_sloppy_assv, 0);
-}
-
-
-SCM_PROC (s_hashv_ref, "hashv-ref", 2, 1, 0, scm_hashv_ref);
-
-SCM
-scm_hashv_ref (table, obj, dflt)
- SCM table;
- SCM obj;
- SCM dflt;
-{
- if (dflt == SCM_UNDEFINED)
- dflt = SCM_BOOL_F;
- return scm_hash_fn_ref (table, obj, dflt, scm_ihashv, scm_sloppy_assv, 0);
-}
-
-
-
-SCM_PROC (s_hashv_set_x, "hashv-set!", 3, 0, 0, scm_hashv_set_x);
-
-SCM
-scm_hashv_set_x (table, obj, val)
- SCM table;
- SCM obj;
- SCM val;
-{
- return scm_hash_fn_set_x (table, obj, val, scm_ihashv, scm_sloppy_assv, 0);
-}
-
-
-SCM_PROC (s_hashv_remove_x, "hashv-remove!", 2, 0, 0, scm_hashv_remove_x);
-
-SCM
-scm_hashv_remove_x (table, obj)
- SCM table;
- SCM obj;
-{
- return scm_hash_fn_remove_x (table, obj, scm_ihashv, scm_sloppy_assv, scm_delv_x, 0);
-}
-
-
-
-SCM_PROC (s_hash_get_handle, "hash-get-handle", 2, 0, 0, scm_hash_get_handle);
-
-SCM
-scm_hash_get_handle (table, obj)
- SCM table;
- SCM obj;
-{
- return scm_hash_fn_get_handle (table, obj, scm_ihash, scm_sloppy_assoc, 0);
-}
-
-
-SCM_PROC (s_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, scm_hash_create_handle_x);
-
-SCM
-scm_hash_create_handle_x (table, obj, init)
- SCM table;
- SCM obj;
- SCM init;
-{
- return scm_hash_fn_create_handle_x (table, obj, init, scm_ihash, scm_sloppy_assoc, 0);
-}
-
-
-SCM_PROC (s_hash_ref, "hash-ref", 2, 1, 0, scm_hash_ref);
-
-SCM
-scm_hash_ref (table, obj, dflt)
- SCM table;
- SCM obj;
- SCM dflt;
-{
- if (dflt == SCM_UNDEFINED)
- dflt = SCM_BOOL_F;
- return scm_hash_fn_ref (table, obj, dflt, scm_ihash, scm_sloppy_assoc, 0);
-}
-
-
-
-SCM_PROC (s_hash_set_x, "hash-set!", 3, 0, 0, scm_hash_set_x);
-
-SCM
-scm_hash_set_x (table, obj, val)
- SCM table;
- SCM obj;
- SCM val;
-{
- return scm_hash_fn_set_x (table, obj, val, scm_ihash, scm_sloppy_assoc, 0);
-}
-
-
-
-SCM_PROC (s_hash_remove_x, "hash-remove!", 2, 0, 0, scm_hash_remove_x);
-
-SCM
-scm_hash_remove_x (table, obj)
- SCM table;
- SCM obj;
-{
- return scm_hash_fn_remove_x (table, obj, scm_ihash, scm_sloppy_assoc, scm_delete_x, 0);
-}
-
-
-
-
-struct scm_ihashx_closure
-{
- SCM hash;
- SCM assoc;
- SCM delete;
-};
-
-
-
-static unsigned int scm_ihashx SCM_P ((SCM obj, unsigned int n, struct scm_ihashx_closure * closure));
-
-static unsigned int
-scm_ihashx (obj, n, closure)
- SCM obj;
- unsigned int n;
- struct scm_ihashx_closure * closure;
-{
- SCM answer;
- SCM_ALLOW_INTS;
- answer = scm_apply (closure->hash,
- scm_listify (obj, scm_ulong2num ((unsigned long)n), SCM_UNDEFINED),
- SCM_EOL);
- SCM_DEFER_INTS;
- return SCM_INUM (answer);
-}
-
-
-
-static SCM scm_sloppy_assx SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure));
-
-static SCM
-scm_sloppy_assx (obj, alist, closure)
- SCM obj;
- SCM alist;
- struct scm_ihashx_closure * closure;
-{
- SCM answer;
- SCM_ALLOW_INTS;
- answer = scm_apply (closure->assoc,
- scm_listify (obj, alist, SCM_UNDEFINED),
- SCM_EOL);
- SCM_DEFER_INTS;
- return answer;
-}
-
-
-
-
-static SCM scm_delx_x SCM_P ((SCM obj, SCM alist, struct scm_ihashx_closure * closure));
-
-static SCM
-scm_delx_x (obj, alist, closure)
- SCM obj;
- SCM alist;
- struct scm_ihashx_closure * closure;
-{
- SCM answer;
- SCM_ALLOW_INTS;
- answer = scm_apply (closure->delete,
- scm_listify (obj, alist, SCM_UNDEFINED),
- SCM_EOL);
- SCM_DEFER_INTS;
- return answer;
-}
-
-
-
-SCM_PROC (s_hashx_get_handle, "hashx-get-handle", 4, 0, 0, scm_hashx_get_handle);
-
-SCM
-scm_hashx_get_handle (hash, assoc, table, obj)
- SCM hash;
- SCM assoc;
- SCM table;
- SCM obj;
-{
- struct scm_ihashx_closure closure;
- closure.hash = hash;
- closure.assoc = assoc;
- return scm_hash_fn_get_handle (table, obj, scm_ihashx, scm_sloppy_assx, (void *)&closure);
-}
-
-
-SCM_PROC (s_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, scm_hashx_create_handle_x);
-
-SCM
-scm_hashx_create_handle_x (hash, assoc, table, obj, init)
- SCM hash;
- SCM assoc;
- SCM table;
- SCM obj;
- SCM init;
-{
- struct scm_ihashx_closure closure;
- closure.hash = hash;
- closure.assoc = assoc;
- return scm_hash_fn_create_handle_x (table, obj, init, scm_ihashx, scm_sloppy_assx, (void *)&closure);
-}
-
-
-
-SCM_PROC (s_hashx_ref, "hashx-ref", 4, 1, 0, scm_hashx_ref);
-
-SCM
-scm_hashx_ref (hash, assoc, table, obj, dflt)
- SCM hash;
- SCM assoc;
- SCM table;
- SCM obj;
- SCM dflt;
-{
- struct scm_ihashx_closure closure;
- if (dflt == SCM_UNDEFINED)
- dflt = SCM_BOOL_F;
- closure.hash = hash;
- closure.assoc = assoc;
- return scm_hash_fn_ref (table, obj, dflt, scm_ihashx, scm_sloppy_assx, (void *)&closure);
-}
-
-
-
-
-SCM_PROC (s_hashx_set_x, "hashx-set!", 5, 0, 0, scm_hashx_set_x);
-
-SCM
-scm_hashx_set_x (hash, assoc, table, obj, val)
- SCM hash;
- SCM assoc;
- SCM table;
- SCM obj;
- SCM val;
-{
- struct scm_ihashx_closure closure;
- closure.hash = hash;
- closure.assoc = assoc;
- return scm_hash_fn_set_x (table, obj, val, scm_ihashx, scm_sloppy_assx, (void *)&closure);
-}
-
-
-
-SCM
-scm_hashx_remove_x (hash, assoc, delete, table, obj)
- SCM hash;
- SCM assoc;
- SCM delete;
- SCM table;
- SCM obj;
-{
- struct scm_ihashx_closure closure;
- closure.hash = hash;
- closure.assoc = assoc;
- closure.delete = delete;
- return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx, scm_delx_x, 0);
-}
-
-
-
-
-void
-scm_init_hashtab ()
-{
-#include "hashtab.x"
-}
-
diff --git a/libguile/hashtab.h b/libguile/hashtab.h
deleted file mode 100644
index f53d25663..000000000
--- a/libguile/hashtab.h
+++ /dev/null
@@ -1,84 +0,0 @@
-/* classes: h_files */
-
-#ifndef HASHTABH
-#define HASHTABH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-
-#if 0
-typedef unsigned int scm_hash_fn_t SCM_P ((SCM obj, unsigned int d, void *closure));
-typedef SCM scm_assoc_fn_t SCM_P ((SCM key, SCM alist, void *closure));
-typedef SCM scm_delete_fn_t SCM_P ((SCM elt, SCM list));
-#endif
-
-extern SCM scm_hash_fn_get_handle SCM_P ((SCM table, SCM obj, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure));
-extern SCM scm_hash_fn_create_handle_x SCM_P ((SCM table, SCM obj, SCM init, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure));
-extern SCM scm_hash_fn_ref SCM_P ((SCM table, SCM obj, SCM dflt, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure));
-extern SCM scm_hash_fn_set_x SCM_P ((SCM table, SCM obj, SCM val, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), void * closure));
-extern SCM scm_hash_fn_remove_x SCM_P ((SCM table, SCM obj, unsigned int (*hash_fn) (), SCM (*assoc_fn) (), SCM (*delete_fn) (), void * closure));
-
-extern SCM scm_hashq_get_handle SCM_P ((SCM table, SCM obj));
-extern SCM scm_hashq_create_handle_x SCM_P ((SCM table, SCM obj, SCM init));
-extern SCM scm_hashq_ref SCM_P ((SCM table, SCM obj, SCM dflt));
-extern SCM scm_hashq_set_x SCM_P ((SCM table, SCM obj, SCM val));
-extern SCM scm_hashq_remove_x SCM_P ((SCM table, SCM obj));
-extern SCM scm_hashv_get_handle SCM_P ((SCM table, SCM obj));
-extern SCM scm_hashv_create_handle_x SCM_P ((SCM table, SCM obj, SCM init));
-extern SCM scm_hashv_ref SCM_P ((SCM table, SCM obj, SCM dflt));
-extern SCM scm_hashv_set_x SCM_P ((SCM table, SCM obj, SCM val));
-extern SCM scm_hashv_remove_x SCM_P ((SCM table, SCM obj));
-extern SCM scm_hash_get_handle SCM_P ((SCM table, SCM obj));
-extern SCM scm_hash_create_handle_x SCM_P ((SCM table, SCM obj, SCM init));
-extern SCM scm_hash_ref SCM_P ((SCM table, SCM obj, SCM dflt));
-extern SCM scm_hash_set_x SCM_P ((SCM table, SCM obj, SCM val));
-extern SCM scm_hash_remove_x SCM_P ((SCM table, SCM obj));
-extern SCM scm_hashx_get_handle SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj));
-extern SCM scm_hashx_create_handle_x SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM init));
-extern SCM scm_hashx_ref SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt));
-extern SCM scm_hashx_set_x SCM_P ((SCM hash, SCM assoc, SCM table, SCM obj, SCM val));
-extern SCM scm_hashx_remove_x SCM_P ((SCM hash, SCM assoc, SCM del, SCM table, SCM obj));
-extern void scm_init_hashtab SCM_P ((void));
-
-#endif /* HASHTABH */
diff --git a/libguile/inet_aton.c b/libguile/inet_aton.c
deleted file mode 100644
index 1d02af5e5..000000000
--- a/libguile/inet_aton.c
+++ /dev/null
@@ -1,157 +0,0 @@
-/*
- * Copyright (c) 1983, 1990, 1993
- * The Regents of the University of California. All rights reserved.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions
- * are met:
- * 1. Redistributions of source code must retain the above copyright
- * notice, this list of conditions and the following disclaimer.
- * 2. Redistributions in binary form must reproduce the above copyright
- * notice, this list of conditions and the following disclaimer in the
- * documentation and/or other materials provided with the distribution.
- * 3. All advertising materials mentioning features or use of this software
- * must display the following acknowledgement:
- * This product includes software developed by the University of
- * California, Berkeley and its contributors.
- * 4. Neither the name of the University nor the names of its contributors
- * may be used to endorse or promote products derived from this software
- * without specific prior written permission.
- *
- * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
- * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
- * SUCH DAMAGE.
- */
-
-#if defined(LIBC_SCCS) && !defined(lint)
-static char sccsid[] = "@(#)inet_addr.c 8.1 (Berkeley) 6/17/93";
-#endif /* LIBC_SCCS and not lint */
-
-#include <ctype.h>
-
-#include <sys/param.h>
-#include <netinet/in.h>
-#include <arpa/inet.h>
-
-#if 0
-
-/*
- * Ascii internet address interpretation routine.
- * The value returned is in network order.
- */
-u_long
-inet_addr(cp)
- register const char *cp;
-{
- struct in_addr val;
-
- if (inet_aton(cp, &val))
- return (val.s_addr);
- return (INADDR_NONE);
-}
-
-#endif
-
-/*
- * Check whether "cp" is a valid ascii representation
- * of an Internet address and convert to a binary address.
- * Returns 1 if the address is valid, 0 if not.
- * This replaces inet_addr, the return value from which
- * cannot distinguish between failure and a local broadcast address.
- */
-int
-inet_aton(cp, addr)
- register const char *cp;
- struct in_addr *addr;
-{
- register unsigned long val;
- register int base, n;
- register char c;
- unsigned int parts[4];
- register unsigned int *pp = parts;
-
- for (;;) {
- /*
- * Collect number up to ``.''.
- * Values are specified as for C:
- * 0x=hex, 0=octal, other=decimal.
- */
- val = 0; base = 10;
- if (*cp == '0') {
- if (*++cp == 'x' || *cp == 'X')
- base = 16, cp++;
- else
- base = 8;
- }
- while ((c = *cp) != '\0') {
- if (isascii(c) && isdigit(c)) {
- val = (val * base) + (c - '0');
- cp++;
- continue;
- }
- if (base == 16 && isascii(c) && isxdigit(c)) {
- val = (val << 4) +
- (c + 10 - (islower(c) ? 'a' : 'A'));
- cp++;
- continue;
- }
- break;
- }
- if (*cp == '.') {
- /*
- * Internet format:
- * a.b.c.d
- * a.b.c (with c treated as 16-bits)
- * a.b (with b treated as 24 bits)
- */
- if (pp >= parts + 3 || val > 0xff)
- return (0);
- *pp++ = val, cp++;
- } else
- break;
- }
- /*
- * Check for trailing characters.
- */
- if (*cp && (!isascii(*cp) || !isspace(*cp)))
- return (0);
- /*
- * Concoct the address according to
- * the number of parts specified.
- */
- n = pp - parts + 1;
- switch (n) {
-
- case 1: /* a -- 32 bits */
- break;
-
- case 2: /* a.b -- 8.24 bits */
- if (val > 0xffffff)
- return (0);
- val |= parts[0] << 24;
- break;
-
- case 3: /* a.b.c -- 8.8.16 bits */
- if (val > 0xffff)
- return (0);
- val |= (parts[0] << 24) | (parts[1] << 16);
- break;
-
- case 4: /* a.b.c.d -- 8.8.8.8 bits */
- if (val > 0xff)
- return (0);
- val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8);
- break;
- }
- if (addr)
- addr->s_addr = htonl(val);
- return (1);
-}
diff --git a/libguile/init.c b/libguile/init.c
deleted file mode 100644
index edbffd208..000000000
--- a/libguile/init.c
+++ /dev/null
@@ -1,454 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-
-/* Everybody has an init function. */
-#include "alist.h"
-#include "append.h"
-#include "arbiters.h"
-#include "async.h"
-#include "backtrace.h"
-#include "boolean.h"
-#include "chars.h"
-#include "continuations.h"
-#ifdef DEBUG_EXTENSIONS
-#include "debug.h"
-#endif
-#include "dynl.h"
-#include "dynwind.h"
-#include "eq.h"
-#include "error.h"
-#include "eval.h"
-#include "fdsocket.h"
-#include "feature.h"
-#include "filesys.h"
-#include "fports.h"
-#include "gc.h"
-#include "gdbint.h"
-#include "gsubr.h"
-#include "hash.h"
-#include "hashtab.h"
-#include "ioext.h"
-#include "kw.h"
-#include "list.h"
-#include "load.h"
-#include "mallocs.h"
-#include "mbstrings.h"
-#include "numbers.h"
-#include "objprop.h"
-#include "options.h"
-#include "pairs.h"
-#include "ports.h"
-#include "posix.h"
-#include "print.h"
-#include "procprop.h"
-#include "procs.h"
-#include "ramap.h"
-#include "read.h"
-#include "scmsigs.h"
-#include "sequences.h"
-#include "simpos.h"
-#include "smob.h"
-#include "socket.h"
-#include "srcprop.h"
-#include "stackchk.h"
-#include "stacks.h"
-#include "stime.h"
-#include "strings.h"
-#include "strop.h"
-#include "strorder.h"
-#include "strports.h"
-#include "struct.h"
-#include "symbols.h"
-#include "tag.h"
-#include "throw.h"
-#include "unif.h"
-#include "variable.h"
-#include "vectors.h"
-#include "version.h"
-#include "vports.h"
-#include "weaks.h"
-
-#include "init.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-
-static void scm_start_stack SCM_P ((void *base));
-static void scm_restart_stack SCM_P ((void * base));
-
-static void
-scm_start_stack (base)
- void * base;
-{
- SCM root;
-
- root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
- scm_set_root (SCM_ROOT_STATE (root));
- scm_stack_base = base;
-
- scm_exitval = SCM_BOOL_F; /* vestigial */
-
- scm_top_level_lookup_closure_var = SCM_BOOL_F;
- scm_system_transformer = SCM_BOOL_F;
-
- /* Create an object to hold the root continuation.
- */
- SCM_NEWCELL (scm_rootcont);
- SCM_SETJMPBUF (scm_rootcont, scm_must_malloc ((long) sizeof (scm_contregs),
- "continuation"));
- SCM_SETCAR (scm_rootcont, scm_tc7_contin);
- SCM_SEQ (scm_rootcont) = 0;
- /* The root continuation if further initialized by scm_restart_stack. */
-
- /* Create the look-aside stack for variables that are shared between
- * captured continuations.
- */
- scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512),
- SCM_UNDEFINED, SCM_UNDEFINED);
- /* The continuation stack is further initialized by scm_restart_stack. */
-
- /* The remainder of stack initialization is factored out to another
- * function so that if this stack is ever exitted, it can be
- * re-entered using scm_restart_stack. */
- scm_restart_stack (base);
-}
-
-
-static void
-scm_restart_stack (base)
- void * base;
-{
- scm_dynwinds = SCM_EOL;
- SCM_DYNENV (scm_rootcont) = SCM_EOL;
- SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
-#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
-#endif
- SCM_BASE (scm_rootcont) = base;
- scm_continuation_stack_ptr = SCM_MAKINUM (0);
-}
-
-#if 0
-static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
-
-
-static void fixconfig SCM_P ((char *s1, char *s2, int s));
-
-static void
-fixconfig (s1, s2, s)
- char *s1;
- char *s2;
- int s;
-{
- fputs (s1, stderr);
- fputs (s2, stderr);
- fputs ("\nin ", stderr);
- fputs (s ? "setjump" : "scmfig", stderr);
- fputs (".h and recompile scm\n", stderr);
- exit (1);
-}
-
-
-static void check_config SCM_P ((void));
-
-static void
-check_config ()
-{
- scm_sizet j;
-
- j = HEAP_SEG_SIZE;
- if (HEAP_SEG_SIZE != j)
- fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
-
-#ifdef SCM_SINGLES
- if (sizeof (float) != sizeof (long))
- fixconfig (remsg, "SCM_SINGLES", 0);
-#endif /* def SCM_SINGLES */
-
-
-#ifdef SCM_BIGDIG
- if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long))
- fixconfig (remsg, "SCM_BIGDIG", 0);
-#ifndef SCM_DIGSTOOBIG
- if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long))
- fixconfig (addmsg, "SCM_DIGSTOOBIG", 0);
-#endif
-#endif
-
-#ifdef SCM_STACK_GROWS_UP
- if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
- fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
-#else
- if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
- fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
-#endif
-}
-#endif
-
-
-
-/* initializing standard and current I/O ports */
-
-/* Create standard ports from stdio stdin, stdout, and stderr. */
-static void
-scm_init_standard_ports ()
-{
- /* I'm not sure why this should be unbuffered when coming from a
- tty; isn't line buffering more common? */
- scm_def_inp = scm_stdio_to_port (stdin,
- (isatty (fileno (stdin)) ? "r0" : "r"),
- "standard input");
- scm_def_outp = scm_stdio_to_port (stdout, "w", "standard output");
- scm_def_errp = scm_stdio_to_port (stderr, "w", "standard error");
-
- scm_cur_inp = scm_def_inp;
- scm_cur_outp = scm_def_outp;
- scm_cur_errp = scm_def_errp;
-}
-
-
-
-#ifdef _UNICOS
-typedef int setjmp_type;
-#else
-typedef long setjmp_type;
-#endif
-
-static void scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base,
- int argc, char **argv,
- void (*main_func) (void *closure,
- int argc,
- char **argv),
- void *closure));
-
-
-/* Fire up the Guile Scheme interpreter.
-
- Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV. MAIN_FUNC
- should do all the work of the program (initializing other packages,
- reading user input, etc.) before returning. When MAIN_FUNC
- returns, call exit (0); this function never returns. If you want
- some other exit value, MAIN_FUNC may call exit itself.
-
- scm_boot_guile arranges for program-arguments to return the strings
- given by ARGC and ARGV. If MAIN_FUNC modifies ARGC/ARGV, should
- call scm_set_program_arguments with the final list, so Scheme code
- will know which arguments have been processed.
-
- Why must the caller do all the real work from MAIN_FUNC? The
- garbage collector assumes that all local variables of type SCM will
- be above scm_boot_guile's stack frame on the stack. If you try to
- manipulate SCM values after this function returns, it's the luck of
- the draw whether the GC will be able to find the objects you
- allocate. So, scm_boot_guile function exits, rather than
- returning, to discourage people from making that mistake. */
-
-
-void
-scm_boot_guile (argc, argv, main_func, closure)
- int argc;
- char ** argv;
- void (*main_func) ();
- void *closure;
-{
- /* The garbage collector uses the address of this variable as one
- end of the stack, and the address of one of its own local
- variables as the other end. */
- SCM_STACKITEM dummy;
-
- return scm_boot_guile_1 (&dummy, argc, argv, main_func, closure);
-}
-
-/* Record here whether SCM_BOOT_GUILE_1 has already been called. This
- variable is now here and not inside SCM_BOOT_GUILE_1 so that one
- can tweak it. This is necessary for unexec to work. (Hey, "1-live"
- is the name of a local radiostation...) */
-
-int scm_boot_guile_1_live = 0;
-
-static void
-scm_boot_guile_1 (base, argc, argv, main_func, closure)
- SCM_STACKITEM *base;
- int argc;
- char **argv;
- void (*main_func) ();
- void *closure;
-{
- static int initialized = 0;
- /* static int live = 0; */
- setjmp_type setjmp_val;
-
- /* This function is not re-entrant. */
- if (scm_boot_guile_1_live)
- abort ();
-
- scm_boot_guile_1_live = 1;
-
- scm_ints_disabled = 1;
- scm_block_gc = 1;
-
- if (initialized)
- {
- scm_restart_stack (base);
- }
- else
- {
- scm_ports_prehistory ();
- scm_smob_prehistory ();
- scm_tables_prehistory ();
- scm_init_storage (0);
- scm_init_root ();
-#ifdef USE_THREADS
- scm_init_threads (base);
-#endif
- scm_start_stack (base);
- scm_init_gsubr ();
- scm_init_feature ();
- scm_init_alist ();
- scm_init_append ();
- scm_init_arbiters ();
- scm_init_async ();
- scm_init_backtrace ();
- scm_init_boolean ();
- scm_init_chars ();
- scm_init_continuations ();
- scm_init_dynwind ();
- scm_init_eq ();
- scm_init_error ();
- scm_init_fdsocket ();
- scm_init_fports ();
- scm_init_filesys ();
- scm_init_gc ();
- scm_init_gdbint ();
- scm_init_hash ();
- scm_init_hashtab ();
- scm_init_ioext ();
- scm_init_kw ();
- scm_init_list ();
- scm_init_mallocs ();
- scm_init_numbers ();
- scm_init_objprop ();
-#if DEBUG_EXTENSIONS
- /* Excluding this until it's really needed makes the binary
- * smaller after linking. */
- scm_init_options ();
-#endif
- scm_init_pairs ();
- scm_init_ports ();
- scm_init_posix ();
- scm_init_procs ();
- scm_init_procprop ();
- scm_init_scmsigs ();
- scm_init_socket ();
-#ifdef DEBUG_EXTENSIONS
- scm_init_srcprop ();
-#endif
- scm_init_stackchk ();
- scm_init_struct (); /* Requires struct */
- scm_init_stacks ();
- scm_init_strports ();
- scm_init_symbols ();
- scm_init_tag ();
- scm_init_load ();
- scm_init_print (); /* Requires struct */
- scm_init_read ();
- scm_init_sequences ();
- scm_init_stime ();
- scm_init_strings ();
- scm_init_strorder ();
- scm_init_mbstrings ();
- scm_init_strop ();
- scm_init_throw ();
- scm_init_variable ();
- scm_init_vectors ();
- scm_init_version ();
- scm_init_weaks ();
- scm_init_vports ();
- scm_init_eval ();
-#ifdef DEBUG_EXTENSIONS
- scm_init_debug (); /* Requires macro smobs */
-#endif
- scm_init_ramap ();
- scm_init_unif ();
- scm_init_simpos ();
- scm_init_load_path ();
- scm_init_standard_ports ();
- scm_init_dynamic_linking ();
- initialized = 1;
- }
-
- scm_block_gc = 0; /* permit the gc to run */
- /* ints still disabled */
-
-#ifdef STACK_CHECKING
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-#endif
-
- setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
- if (!setjmp_val)
- {
- scm_init_signals ();
-
- scm_set_program_arguments (argc, argv, 0);
- (*main_func) (closure, argc, argv);
- }
-
- scm_restore_signals ();
-
- /* This tick gives any pending
- * asyncs a chance to run. This must be done after
- * the call to scm_restore_signals.
- */
- SCM_ASYNC_TICK;
-
- /* If the caller doesn't want this, they should return from
- main_func themselves. */
- exit (0);
-}
diff --git a/libguile/init.h b/libguile/init.h
deleted file mode 100644
index 97fb5e182..000000000
--- a/libguile/init.h
+++ /dev/null
@@ -1,56 +0,0 @@
-/* classes: h_files */
-
-#ifndef INITH
-#define INITH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-extern void scm_boot_guile SCM_P ((int argc, char **argv,
- void (*main_func) (void *closure,
- int argc,
- char **argv),
- void *closure));
-
-#endif /* INITH */
diff --git a/libguile/ioext.c b/libguile/ioext.c
deleted file mode 100644
index 37b8bdc34..000000000
--- a/libguile/ioext.c
+++ /dev/null
@@ -1,458 +0,0 @@
-/* Copyright (C) 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-
-#include <stdio.h>
-#include "fd.h"
-#include "_scm.h"
-#include "fports.h"
-
-#include "ioext.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-
-SCM_PROC (s_sys_ftell, "ftell", 1, 0, 0, scm_sys_ftell);
-
-SCM
-scm_sys_ftell (port)
- SCM port;
-{
- long pos;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_ftell);
- SCM_SYSCALL (pos = ftell ((FILE *)SCM_STREAM (port)));
- if (pos < 0)
- scm_syserror (s_sys_ftell);
- if (pos > 0 && SCM_CRDYP (port))
- pos--;
- return scm_long2num (pos);
-}
-
-
-
-SCM_PROC (s_sys_fseek, "fseek", 3, 0, 0, scm_sys_fseek);
-
-SCM
-scm_sys_fseek (port, offset, whence)
- SCM port;
- SCM offset;
- SCM whence;
-{
- int rv;
- long loff;
-
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fseek);
- loff = scm_num2long (offset, (char *)SCM_ARG2, s_sys_fseek);
- SCM_ASSERT (SCM_INUMP (whence) && (SCM_INUM (whence) < 3) && (SCM_INUM (whence) >= 0),
- whence, SCM_ARG3, s_sys_fseek);
-
- SCM_CLRDY (port); /* Clear ungetted char */
- /* Values of whence are interned in scm_init_ioext. */
- rv = fseek ((FILE *)SCM_STREAM (port), loff, SCM_INUM (whence));
- if (rv != 0)
- scm_syserror (s_sys_fseek);
- return SCM_UNSPECIFIED;
-}
-
-
-
-SCM_PROC (s_sys_freopen, "freopen", 3, 0, 0, scm_sys_freopen);
-
-SCM
-scm_sys_freopen (filename, modes, port)
- SCM filename;
- SCM modes;
- SCM port;
-{
- FILE *f;
- SCM_ASSERT (SCM_NIMP (filename) && SCM_STRINGP (filename), filename, SCM_ARG1, s_sys_freopen);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_freopen);
- SCM_DEFER_INTS;
- SCM_ASSERT (SCM_NIMP (port) && SCM_FPORTP (port), port, SCM_ARG3, s_sys_freopen);
- SCM_SYSCALL (f = freopen (SCM_CHARS (filename), SCM_CHARS (modes), (FILE *)SCM_STREAM (port)));
- if (!f)
- {
- SCM p;
- p = port;
- port = SCM_MAKINUM (errno);
- SCM_SETAND_CAR (p, ~SCM_OPN);
- scm_remove_from_port_table (p);
- }
- else
- {
- SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes)));
- SCM_SETSTREAM (port, (SCM)f);
- SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes)));
- if (SCM_BUF0 & SCM_CAR (port))
- scm_setbuf0 (port);
- }
- SCM_ALLOW_INTS;
- return port;
-}
-
-
-
-SCM_PROC (s_sys_duplicate_port, "duplicate-port", 2, 0, 0, scm_sys_duplicate_port);
-
-SCM
-scm_sys_duplicate_port (oldpt, modes)
- SCM oldpt;
- SCM modes;
-{
- int oldfd;
- int newfd;
- FILE *f;
- SCM newpt;
- SCM_ASSERT (SCM_NIMP (oldpt) && SCM_OPPORTP (oldpt), oldpt, SCM_ARG1, s_sys_duplicate_port);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_duplicate_port);
- SCM_NEWCELL (newpt);
- SCM_DEFER_INTS;
- oldfd = fileno ((FILE *)SCM_STREAM (oldpt));
- if (oldfd == -1)
- scm_syserror (s_sys_duplicate_port);
- SCM_SYSCALL (newfd = dup (oldfd));
- if (newfd == -1)
- scm_syserror (s_sys_duplicate_port);
- f = fdopen (newfd, SCM_CHARS (modes));
- if (!f)
- {
- SCM_SYSCALL (close (newfd));
- scm_syserror (s_sys_duplicate_port);
- }
- {
- struct scm_port_table * pt;
- pt = scm_add_to_port_table (newpt);
- SCM_SETPTAB_ENTRY (newpt, pt);
- SCM_SETCAR (newpt, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes)));
- if (SCM_BUF0 & SCM_CAR (newpt))
- scm_setbuf0 (newpt);
- SCM_SETSTREAM (newpt, (SCM)f);
- SCM_PTAB_ENTRY (newpt)->file_name = SCM_PTAB_ENTRY (oldpt)->file_name;
- }
- SCM_ALLOW_INTS;
- return newpt;
-}
-
-
-
-SCM_PROC (s_sys_redirect_port, "redirect-port", 2, 0, 0, scm_sys_redirect_port);
-
-SCM
-scm_sys_redirect_port (into_pt, from_pt)
- SCM into_pt;
- SCM from_pt;
-{
- int ans, oldfd, newfd;
- SCM_DEFER_INTS;
- SCM_ASSERT (SCM_NIMP (into_pt) && SCM_OPPORTP (into_pt), into_pt, SCM_ARG1, s_sys_redirect_port);
- SCM_ASSERT (SCM_NIMP (from_pt) && SCM_OPPORTP (from_pt), from_pt, SCM_ARG2, s_sys_redirect_port);
- oldfd = fileno ((FILE *)SCM_STREAM (into_pt));
- if (oldfd == -1)
- scm_syserror (s_sys_redirect_port);
- newfd = fileno ((FILE *)SCM_STREAM (from_pt));
- if (newfd == -1)
- scm_syserror (s_sys_redirect_port);
- SCM_SYSCALL (ans = dup2 (oldfd, newfd));
- if (ans == -1)
- scm_syserror (s_sys_redirect_port);
- SCM_ALLOW_INTS;
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_sys_fileno, "fileno", 1, 0, 0, scm_sys_fileno);
-
-SCM
-scm_sys_fileno (port)
- SCM port;
-{
- int fd;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_fileno);
- fd = fileno ((FILE *)SCM_STREAM (port));
- if (fd == -1)
- scm_syserror (s_sys_fileno);
- return SCM_MAKINUM (fd);
-}
-
-SCM_PROC (s_sys_isatty, "isatty?", 1, 0, 0, scm_sys_isatty_p);
-
-SCM
-scm_sys_isatty_p (port)
- SCM port;
-{
- int rv;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_isatty);
- rv = fileno ((FILE *)SCM_STREAM (port));
- if (rv == -1)
- scm_syserror (s_sys_isatty);
- rv = isatty (rv);
- return rv ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-
-SCM_PROC (s_sys_fdopen, "fdopen", 2, 0, 0, scm_sys_fdopen);
-
-SCM
-scm_sys_fdopen (fdes, modes)
- SCM fdes;
- SCM modes;
-{
- FILE *f;
- SCM port;
- struct scm_port_table * pt;
-
- SCM_ASSERT (SCM_INUMP (fdes), fdes, SCM_ARG1, s_sys_fdopen);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_sys_fdopen);
- SCM_NEWCELL (port);
- SCM_DEFER_INTS;
- f = fdopen (SCM_INUM (fdes), SCM_CHARS (modes));
- if (f == NULL)
- scm_syserror (s_sys_fdopen);
- pt = scm_add_to_port_table (port);
- SCM_SETPTAB_ENTRY (port, pt);
- SCM_SETCAR (port, scm_tc16_fport | scm_mode_bits (SCM_CHARS (modes)));
- if (SCM_BUF0 & SCM_CAR (port))
- scm_setbuf0 (port);
- SCM_SETSTREAM (port, (SCM)f);
- SCM_ALLOW_INTS;
- return port;
-}
-
-
-
-/* Move a port's underlying file descriptor to a given value.
- * Returns #f if fdes is already the given value.
- * #t if fdes moved.
- * MOVE->FDES is implemented in Scheme and calls this primitive.
- */
-SCM_PROC (s_sys_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, scm_sys_primitive_move_to_fdes);
-
-SCM
-scm_sys_primitive_move_to_fdes (port, fd)
- SCM port;
- SCM fd;
-{
- FILE *stream;
- int old_fd;
- int new_fd;
- int rv;
-
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_sys_primitive_move_to_fdes);
- SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG2, s_sys_primitive_move_to_fdes);
- SCM_DEFER_INTS;
- stream = (FILE *)SCM_STREAM (port);
- old_fd = fileno (stream);
- new_fd = SCM_INUM (fd);
- if (old_fd == new_fd)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
- scm_evict_ports (new_fd);
- rv = dup2 (old_fd, new_fd);
- if (rv == -1)
- scm_syserror (s_sys_primitive_move_to_fdes);
- scm_setfileno (stream, new_fd);
- SCM_SYSCALL (close (old_fd));
- SCM_ALLOW_INTS;
- return SCM_BOOL_T;
-}
-
-
-void
-scm_setfileno (fs, fd)
- FILE *fs;
- int fd;
-{
-#ifdef SET_FILE_FD_FIELD
- SET_FILE_FD_FIELD(fs, fd);
-#else
- Configure could not guess the name of the correct field in a FILE *.
-
- This function needs to be ported to your system.
-
- SET_FILE_FD_FIELD should change the descriptor refered to by a stdio
- stream, and nothing else.
-
- The way to port this file is to add cases to configure.in. Search
- that file for "SET_FILE_FD_FIELD" and follow the examples there.
-#endif
-}
-
-/* Move ports with the specified file descriptor to new descriptors,
- * reseting the revealed count to 0.
- * Should be called with SCM_DEFER_INTS active.
- */
-
-void
-scm_evict_ports (fd)
- int fd;
-{
- int i;
-
- for (i = 0; i < scm_port_table_size; i++)
- {
- if (SCM_FPORTP (scm_port_table[i]->port)
- && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == fd)
- {
- scm_setfileno ((FILE *)SCM_STREAM (scm_port_table[i]->port), dup (fd));
- scm_set_port_revealed_x (scm_port_table[i]->port, SCM_MAKINUM (0));
- }
- }
-}
-
-/* Return a list of ports using a given file descriptor. */
-SCM_PROC(s_fdes_to_ports, "fdes->ports", 1, 0, 0, scm_fdes_to_ports);
-
-SCM
-scm_fdes_to_ports (fd)
- SCM fd;
-{
- SCM result = SCM_EOL;
- int int_fd;
- int i;
-
- SCM_ASSERT (SCM_INUMP (fd), fd, SCM_ARG1, s_fdes_to_ports);
- int_fd = SCM_INUM (fd);
-
- SCM_DEFER_INTS;
- for (i = 0; i < scm_port_table_size; i++)
- {
- if (SCM_FPORTP (scm_port_table[i]->port)
- && fileno ((FILE *)SCM_STREAM (scm_port_table[i]->port)) == int_fd)
- result = scm_cons (scm_port_table[i]->port, result);
- }
- SCM_ALLOW_INTS;
- return result;
-}
-
-
-void
-scm_init_ioext ()
-{
- /* fseek() symbols. */
- scm_sysintern ("SEEK_SET", SCM_MAKINUM (SEEK_SET));
- scm_sysintern ("SEEK_CUR", SCM_MAKINUM (SEEK_CUR));
- scm_sysintern ("SEEK_END", SCM_MAKINUM (SEEK_END));
-
- /* File type/permission bits. */
-#ifdef S_IRUSR
- scm_sysintern ("S_IRUSR", SCM_MAKINUM (S_IRUSR));
-#endif
-#ifdef S_IWUSR
- scm_sysintern ("S_IWUSR", SCM_MAKINUM (S_IWUSR));
-#endif
-#ifdef S_IXUSR
- scm_sysintern ("S_IXUSR", SCM_MAKINUM (S_IXUSR));
-#endif
-#ifdef S_IRWXU
- scm_sysintern ("S_IRWXU", SCM_MAKINUM (S_IRWXU));
-#endif
-
-#ifdef S_IRGRP
- scm_sysintern ("S_IRGRP", SCM_MAKINUM (S_IRGRP));
-#endif
-#ifdef S_IWGRP
- scm_sysintern ("S_IWGRP", SCM_MAKINUM (S_IWGRP));
-#endif
-#ifdef S_IXGRP
- scm_sysintern ("S_IXGRP", SCM_MAKINUM (S_IXGRP));
-#endif
-#ifdef S_IRWXG
- scm_sysintern ("S_IRWXG", SCM_MAKINUM (S_IRWXG));
-#endif
-
-#ifdef S_IROTH
- scm_sysintern ("S_IROTH", SCM_MAKINUM (S_IROTH));
-#endif
-#ifdef S_IWOTH
- scm_sysintern ("S_IWOTH", SCM_MAKINUM (S_IWOTH));
-#endif
-#ifdef S_IXOTH
- scm_sysintern ("S_IXOTH", SCM_MAKINUM (S_IXOTH));
-#endif
-#ifdef S_IRWXO
- scm_sysintern ("S_IRWXO", SCM_MAKINUM (S_IRWXO));
-#endif
-
-#ifdef S_ISUID
- scm_sysintern ("S_ISUID", SCM_MAKINUM (S_ISUID));
-#endif
-#ifdef S_ISGID
- scm_sysintern ("S_ISGID", SCM_MAKINUM (S_ISGID));
-#endif
-#ifdef S_ISVTX
- scm_sysintern ("S_ISVTX", SCM_MAKINUM (S_ISVTX));
-#endif
-
-#ifdef S_IFMT
- scm_sysintern ("S_IFMT", SCM_MAKINUM (S_IFMT));
-#endif
-#ifdef S_IFDIR
- scm_sysintern ("S_IFDIR", SCM_MAKINUM (S_IFDIR));
-#endif
-#ifdef S_IFCHR
- scm_sysintern ("S_IFCHR", SCM_MAKINUM (S_IFCHR));
-#endif
-#ifdef S_IFBLK
- scm_sysintern ("S_IFBLK", SCM_MAKINUM (S_IFBLK));
-#endif
-#ifdef S_IFREG
- scm_sysintern ("S_IFREG", SCM_MAKINUM (S_IFREG));
-#endif
-#ifdef S_IFLNK
- scm_sysintern ("S_IFLNK", SCM_MAKINUM (S_IFLNK));
-#endif
-#ifdef S_IFSOCK
- scm_sysintern ("S_IFSOCK", SCM_MAKINUM (S_IFSOCK));
-#endif
-#ifdef S_IFIFO
- scm_sysintern ("S_IFIFO", SCM_MAKINUM (S_IFIFO));
-#endif
-#include "ioext.x"
-}
-
diff --git a/libguile/ioext.h b/libguile/ioext.h
deleted file mode 100644
index e026a1f23..000000000
--- a/libguile/ioext.h
+++ /dev/null
@@ -1,68 +0,0 @@
-/* classes: h_files */
-
-#ifndef IOEXTH
-#define IOEXTH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-
-
-
-extern SCM scm_sys_ftell SCM_P ((SCM port));
-extern SCM scm_sys_fseek SCM_P ((SCM port, SCM offset, SCM whence));
-extern SCM scm_sys_freopen SCM_P ((SCM filename, SCM modes, SCM port));
-extern SCM scm_sys_duplicate_port SCM_P ((SCM oldpt, SCM modes));
-extern SCM scm_sys_redirect_port SCM_P ((SCM into_pt, SCM from_pt));
-extern SCM scm_sys_fileno SCM_P ((SCM port));
-extern SCM scm_sys_isatty_p SCM_P ((SCM port));
-extern SCM scm_sys_fdopen SCM_P ((SCM fdes, SCM modes));
-extern SCM scm_sys_primitive_move_to_fdes SCM_P ((SCM port, SCM fd));
-extern void scm_setfileno SCM_P ((FILE *fs, int fd));
-extern void scm_evict_ports SCM_P ((int fd));
-extern SCM scm_fdes_to_ports SCM_P ((SCM fd));
-extern void scm_init_ioext SCM_P ((void));
-
-#endif /* IOEXTH */
diff --git a/libguile/kw.c b/libguile/kw.c
deleted file mode 100644
index 76ca88050..000000000
--- a/libguile/kw.c
+++ /dev/null
@@ -1,148 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "genio.h"
-#include "mbstrings.h"
-#include "smob.h"
-
-#include "kw.h"
-
-
-
-static scm_sizet free_kw SCM_P ((SCM obj));
-
-static scm_sizet
-free_kw (obj)
- SCM obj;
-{
- return 0;
-}
-
-
-static int prin_kw SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-
-static int
-prin_kw (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_gen_puts (scm_regular_string, ":", port);
- scm_gen_puts((SCM_MB_STRINGP(SCM_CDR (exp))
- ? scm_mb_string
- : scm_regular_string),
- 1 + SCM_CHARS (SCM_CDR (exp)),
- port);
- return 1;
-}
-
-int scm_tc16_kw;
-
-static scm_smobfuns kw_smob = {scm_markcdr, free_kw, prin_kw, 0};
-
-
-
-SCM_PROC (s_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, scm_make_keyword_from_dash_symbol);
-
-SCM
-scm_make_keyword_from_dash_symbol (symbol)
- SCM symbol;
-{
- SCM vcell;
-
- SCM_ASSERT (SCM_NIMP (symbol) && SCM_SYMBOLP(symbol) && ('-' == SCM_CHARS(symbol)[0]),
- symbol, SCM_ARG1, s_make_keyword_from_dash_symbol);
-
-
- SCM_DEFER_INTS;
- vcell = scm_sym2ovcell_soft (symbol, scm_kw_obarray);
- if (vcell == SCM_BOOL_F)
- {
- SCM kw;
- SCM_NEWCELL(kw);
- SCM_SETCAR (kw, (SCM)scm_tc16_kw);
- SCM_SETCDR (kw, symbol);
- scm_intern_symbol (scm_kw_obarray, symbol);
- vcell = scm_sym2ovcell_soft (symbol, scm_kw_obarray);
- SCM_SETCDR (vcell, kw);
- }
- SCM_ALLOW_INTS;
- return SCM_CDR (vcell);
-}
-
-SCM_PROC(s_keyword_p, "keyword?", 1, 0, 0, scm_keyword_p);
-
-SCM
-scm_keyword_p (obj)
- SCM obj;
-{
- return ( (SCM_NIMP(obj) && SCM_KEYWORDP (obj))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-
-SCM_PROC(s_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0, scm_keyword_dash_symbol);
-
-SCM
-scm_keyword_dash_symbol (kw)
- SCM kw;
-{
- SCM_ASSERT (SCM_NIMP (kw) && SCM_KEYWORDP (kw), kw, SCM_ARG1, s_keyword_dash_symbol);
- return SCM_CDR (kw);
-}
-
-
-
-
-
-void
-scm_init_kw ()
-{
- scm_tc16_kw = scm_newsmob (&kw_smob);
- scm_kw_obarray = scm_make_vector (SCM_MAKINUM (256), SCM_EOL, SCM_UNDEFINED);
-#include "kw.x"
-}
-
diff --git a/libguile/kw.h b/libguile/kw.h
deleted file mode 100644
index 89387c5b3..000000000
--- a/libguile/kw.h
+++ /dev/null
@@ -1,63 +0,0 @@
-/* classes: h_files */
-
-#ifndef KWH
-#define KWH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-extern int scm_tc16_kw;
-#define SCM_KEYWORDP(X) (SCM_CAR(X) == scm_tc16_kw)
-#define SCM_KEYWORDSYM(X) (SCM_CDR(X))
-
-
-
-
-extern SCM scm_make_keyword_from_dash_symbol SCM_P ((SCM symbol));
-extern SCM scm_keyword_p SCM_P ((SCM obj));
-extern SCM scm_keyword_dash_symbol SCM_P ((SCM kw));
-extern void scm_init_kw SCM_P ((void));
-
-#endif /* KWH */
diff --git a/libguile/libguile.h b/libguile/libguile.h
deleted file mode 100644
index 448d2de0a..000000000
--- a/libguile/libguile.h
+++ /dev/null
@@ -1,131 +0,0 @@
-#ifndef LIBGUILEH
-#define LIBGUILEH
-
-/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-
-
-#include "libguile/__scm.h"
-
-/* These files define typedefs used by later files, so they need to
- come first. */
-#include "libguile/print.h"
-#include "libguile/smob.h"
-#include "libguile/pairs.h"
-
-#include "libguile/alist.h"
-#include "libguile/append.h"
-#include "libguile/arbiters.h"
-#include "libguile/async.h"
-#include "libguile/boolean.h"
-#include "libguile/chars.h"
-#include "libguile/continuations.h"
-#ifdef DEBUG_EXTENSIONS
-#include "libguile/backtrace.h"
-#include "libguile/debug.h"
-#include "libguile/stacks.h"
-#endif
-#include "libguile/dynwind.h"
-#include "libguile/eq.h"
-#include "libguile/error.h"
-#include "libguile/eval.h"
-#include "libguile/extchrs.h"
-#include "libguile/fdsocket.h"
-#include "libguile/feature.h"
-#include "libguile/filesys.h"
-#include "libguile/fports.h"
-#include "libguile/gc.h"
-#include "libguile/gdbint.h"
-#include "libguile/genio.h"
-#include "libguile/gsubr.h"
-#include "libguile/hash.h"
-#include "libguile/hashtab.h"
-#include "libguile/init.h"
-#include "libguile/ioext.h"
-#include "libguile/kw.h"
-#include "libguile/libpath.h"
-#include "libguile/list.h"
-#include "libguile/load.h"
-#include "libguile/mallocs.h"
-#include "libguile/markers.h"
-#include "libguile/mbstrings.h"
-#include "libguile/numbers.h"
-#include "libguile/objprop.h"
-#include "libguile/options.h"
-#include "libguile/ports.h"
-#include "libguile/posix.h"
-#include "libguile/procprop.h"
-#include "libguile/procs.h"
-#include "libguile/ramap.h"
-#include "libguile/read.h"
-#include "libguile/root.h"
-#include "libguile/scmsigs.h"
-#include "libguile/sequences.h"
-#include "libguile/simpos.h"
-#include "libguile/snarf.h"
-#include "libguile/socket.h"
-#include "libguile/srcprop.h"
-#include "libguile/stackchk.h"
-#include "libguile/stime.h"
-#include "libguile/strings.h"
-#include "libguile/strop.h"
-#include "libguile/strorder.h"
-#include "libguile/strports.h"
-#include "libguile/struct.h"
-#include "libguile/symbols.h"
-#include "libguile/tag.h"
-#include "libguile/tags.h"
-#include "libguile/throw.h"
-#include "libguile/unif.h"
-#include "libguile/variable.h"
-#include "libguile/vectors.h"
-#include "libguile/version.h"
-#include "libguile/vports.h"
-#include "libguile/weaks.h"
-#ifdef USE_THREADS
-#include "libguile/../threads/threads.h"
-#endif
-
-
-
-#endif /* LIBGUILEH */
diff --git a/libguile/list.c b/libguile/list.c
deleted file mode 100644
index 53f5da1fd..000000000
--- a/libguile/list.c
+++ /dev/null
@@ -1,655 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include <stdio.h>
-#include "_scm.h"
-#include "eq.h"
-
-#include "list.h"
-
-#ifdef __STDC__
-#include <stdarg.h>
-#define var_start(x, y) va_start(x, y)
-#else
-#include <varargs.h>
-#define var_start(x, y) va_start(x)
-#endif
-
-
-/* creating lists */
-
-/* SCM_P won't help us deal with varargs here. */
-#ifdef __STDC__
-SCM
-scm_listify (SCM elt, ...)
-#else
-SCM
-scm_listify (elt, va_alist)
- SCM elt;
- va_dcl
-#endif
-{
- va_list foo;
- SCM answer;
- SCM *pos;
-
- var_start (foo, elt);
- answer = SCM_EOL;
- pos = &answer;
- while (elt != SCM_UNDEFINED)
- {
- *pos = scm_cons (elt, SCM_EOL);
- pos = SCM_CDRLOC (*pos);
- elt = va_arg (foo, SCM);
- }
- return answer;
-}
-
-
-SCM_PROC(s_list, "list", 0, 0, 1, scm_list);
-SCM
-scm_list(objs)
- SCM objs;
-{
- return objs;
-}
-
-
-
-
-/* general questions about lists --- null?, list?, length, etc. */
-
-SCM_PROC(s_null_p, "null?", 1, 0, 0, scm_null_p);
-SCM
-scm_null_p(x)
- SCM x;
-{
- return SCM_NULLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_list_p, "list?", 1, 0, 0, scm_list_p);
-SCM
-scm_list_p(x)
- SCM x;
-{
- if (scm_ilength(x)<0)
- return SCM_BOOL_F;
- else
- return SCM_BOOL_T;
-}
-
-
-/* Return the length of SX, or -1 if it's not a proper list.
- This uses the "tortoise and hare" algorithm to detect "infinitely
- long" lists (i.e. lists with cycles in their cdrs), and returns -1
- if it does find one. */
-long
-scm_ilength(sx)
- SCM sx;
-{
- register long i = 0;
- register SCM tortoise = sx;
- register SCM hare = sx;
-
- do {
- if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1;
- if SCM_NCONSP(hare) return -1;
- hare = SCM_CDR(hare);
- i++;
- if SCM_IMP(hare) return SCM_NULLP(hare) ? i : -1;
- if SCM_NCONSP(hare) return -1;
- hare = SCM_CDR(hare);
- i++;
- /* For every two steps the hare takes, the tortoise takes one. */
- tortoise = SCM_CDR(tortoise);
- }
- while (hare != tortoise);
-
- /* If the tortoise ever catches the hare, then the list must contain
- a cycle. */
- return -1;
-}
-
-SCM_PROC(s_list_length, "list-length", 1, 0, 0, scm_list_length);
-SCM
-scm_list_length(x)
- SCM x;
-{
- int i;
- i = scm_ilength(x);
- SCM_ASSERT(i >= 0, x, SCM_ARG1, s_list_length);
- return SCM_MAKINUM (i);
-}
-
-
-
-/* appending lists */
-
-SCM_PROC (s_list_append, "list-append", 0, 0, 1, scm_list_append);
-SCM
-scm_list_append(args)
- SCM args;
-{
- SCM res = SCM_EOL;
- SCM *lloc = &res, arg;
- if SCM_IMP(args) {
- SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append);
- return res;
- }
- SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append);
- while (1) {
- arg = SCM_CAR(args);
- args = SCM_CDR(args);
- if SCM_IMP(args) {
- *lloc = arg;
- SCM_ASSERT(SCM_NULLP(args), args, SCM_ARGn, s_list_append);
- return res;
- }
- SCM_ASSERT(SCM_CONSP(args), args, SCM_ARGn, s_list_append);
- for(;SCM_NIMP(arg);arg = SCM_CDR(arg)) {
- SCM_ASSERT(SCM_CONSP(arg), arg, SCM_ARGn, s_list_append);
- *lloc = scm_cons(SCM_CAR(arg), SCM_EOL);
- lloc = SCM_CDRLOC(*lloc);
- }
- SCM_ASSERT(SCM_NULLP(arg), arg, SCM_ARGn, s_list_append);
- }
-}
-
-
-SCM_PROC (s_list_append_x, "list-append!", 0, 0, 1, scm_list_append_x);
-SCM
-scm_list_append_x(args)
- SCM args;
-{
- SCM arg;
- tail:
- if SCM_NULLP(args) return SCM_EOL;
- arg = SCM_CAR(args);
- SCM_ASSERT(SCM_NULLP(arg) || (SCM_NIMP(arg) && SCM_CONSP(arg)), arg, SCM_ARG1, s_list_append_x);
- args = SCM_CDR(args);
- if SCM_NULLP(args) return arg;
- if SCM_NULLP(arg) goto tail;
- SCM_SETCDR (scm_last_pair (arg), scm_list_append_x (args));
- return arg;
-}
-
-
-SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair);
-SCM
-scm_last_pair(sx)
- SCM sx;
-{
- register SCM res = sx;
- register SCM x;
-
- if (SCM_NULLP (sx))
- return SCM_EOL;
-
- SCM_ASSERT(SCM_NIMP(res) && SCM_CONSP(res), res, SCM_ARG1, s_last_pair);
- while (!0) {
- x = SCM_CDR(res);
- if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
- res = x;
- x = SCM_CDR(res);
- if (SCM_IMP(x) || SCM_NCONSP(x)) return res;
- res = x;
- sx = SCM_CDR(sx);
- SCM_ASSERT(x != sx, sx, SCM_ARG1, s_last_pair);
- }
-}
-
-
-/* reversing lists */
-
-SCM_PROC (s_list_reverse, "list-reverse", 1, 0, 0, scm_list_reverse);
-SCM
-scm_list_reverse(lst)
- SCM lst;
-{
- SCM res = SCM_EOL;
- SCM p = lst;
- for(;SCM_NIMP(p);p = SCM_CDR(p)) {
- SCM_ASSERT(SCM_CONSP(p), lst, SCM_ARG1, s_list_reverse);
- res = scm_cons(SCM_CAR(p), res);
- }
- SCM_ASSERT(SCM_NULLP(p), lst, SCM_ARG1, s_list_reverse);
- return res;
-}
-
-SCM_PROC (s_list_reverse_x, "list-reverse!", 1, 1, 0, scm_list_reverse_x);
-SCM
-scm_list_reverse_x (lst, newtail)
- SCM lst;
- SCM newtail;
-{
- SCM old_tail;
- if (newtail == SCM_UNDEFINED)
- newtail = SCM_EOL;
-
- loop:
- if (!(SCM_NIMP (lst) && SCM_CONSP (lst)))
- return lst;
-
- old_tail = SCM_CDR (lst);
- SCM_SETCDR (lst, newtail);
- if (SCM_NULLP (old_tail))
- return lst;
-
- newtail = lst;
- lst = old_tail;
- goto loop;
-}
-
-
-
-/* indexing lists by element number */
-
-SCM_PROC(s_list_ref, "list-ref", 2, 0, 0, scm_list_ref);
-SCM
-scm_list_ref(lst, k)
- SCM lst;
- SCM k;
-{
- register long i;
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_ref);
- i = SCM_INUM(k);
- SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_ref);
- while (i-- > 0) {
- SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
- lst = SCM_CDR(lst);
- }
-erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
- SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_ref);
- return SCM_CAR(lst);
-}
-
-SCM_PROC(s_list_set_x, "list-set!", 3, 0, 0, scm_list_set_x);
-SCM
-scm_list_set_x(lst, k, val)
- SCM lst;
- SCM k;
- SCM val;
-{
- register long i;
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_set_x);
- i = SCM_INUM(k);
- SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_set_x);
- while (i-- > 0) {
- SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
- lst = SCM_CDR(lst);
- }
-erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
- SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_set_x);
- SCM_SETCAR (lst, val);
- return val;
-}
-
-
-SCM_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
-SCM_PROC(s_list_tail, "list-tail", 2, 0, 0, scm_list_tail);
-SCM
-scm_list_tail(lst, k)
- SCM lst;
- SCM k;
-{
- register long i;
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_tail);
- i = SCM_INUM(k);
- while (i-- > 0) {
- SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_tail);
- lst = SCM_CDR(lst);
- }
- return lst;
-}
-
-
-SCM_PROC(s_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, scm_list_cdr_set_x);
-SCM
-scm_list_cdr_set_x(lst, k, val)
- SCM lst;
- SCM k;
- SCM val;
-{
- register long i;
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_cdr_set_x);
- i = SCM_INUM(k);
- SCM_ASSERT(i >= 0, k, SCM_ARG2, s_list_cdr_set_x);
- while (i-- > 0) {
- SCM_ASRTGO(SCM_NIMP(lst) && SCM_CONSP(lst), erout);
- lst = SCM_CDR(lst);
- }
-erout: SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst),
- SCM_NULLP(lst)?k:lst, SCM_NULLP(lst)?SCM_OUTOFRANGE:SCM_ARG1, s_list_cdr_set_x);
- SCM_SETCDR (lst, val);
- return val;
-}
-
-
-
-/* copying lists, perhaps partially */
-
-SCM_PROC(s_list_head, "list-head", 2, 0, 0, scm_list_head);
-SCM
-scm_list_head(lst, k)
- SCM lst;
- SCM k;
-{
- SCM answer;
- SCM * pos;
- register long i;
-
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_list_head);
- answer = SCM_EOL;
- pos = &answer;
- i = SCM_INUM(k);
- while (i-- > 0)
- {
- SCM_ASSERT(SCM_NIMP(lst) && SCM_CONSP(lst), lst, SCM_ARG1, s_list_head);
- *pos = scm_cons (SCM_CAR (lst), SCM_EOL);
- pos = SCM_CDRLOC (*pos);
- lst = SCM_CDR(lst);
- }
- return answer;
-}
-
-
-SCM_PROC (s_list_copy, "list-copy", 1, 0, 0, scm_list_copy);
-SCM
-scm_list_copy (lst)
- SCM lst;
-{
- SCM newlst;
- SCM * fill_here;
- SCM from_here;
-
- newlst = SCM_EOL;
- fill_here = &newlst;
- from_here = lst;
-
- while (SCM_NIMP (from_here) && SCM_CONSP (from_here))
- {
- SCM c;
- c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
- *fill_here = c;
- fill_here = SCM_CDRLOC (c);
- from_here = SCM_CDR (from_here);
- }
- return newlst;
-}
-
-
-/* membership tests (memq, memv, etc.) */
-
-static void sloppy_mem_check SCM_P ((SCM obj, char * where, char * why));
-
-static void
-sloppy_mem_check (obj, where, why)
- SCM obj;
- char * where;
- char * why;
-{
- SCM_ASSERT ((scm_ilength (obj) >= 0), obj, where, why);
-}
-
-
-SCM_PROC (s_sloppy_memq, "sloppy-memq", 2, 0, 0, scm_sloppy_memq);
-SCM
-scm_sloppy_memq(x, lst)
- SCM x;
- SCM lst;
-{
- for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
- {
- if (SCM_CAR(lst)==x)
- return lst;
- }
- return lst;
-}
-
-
-SCM_PROC (s_sloppy_memv, "sloppy-memv", 2, 0, 0, scm_sloppy_memv);
-SCM
-scm_sloppy_memv(x, lst)
- SCM x;
- SCM lst;
-{
- for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
- {
- if (SCM_BOOL_F != scm_eqv_p (SCM_CAR(lst), x))
- return lst;
- }
- return lst;
-}
-
-
-SCM_PROC (s_sloppy_member, "sloppy-member", 2, 0, 0, scm_sloppy_member);
-SCM
-scm_sloppy_member (x, lst)
- SCM x;
- SCM lst;
-{
- for(; SCM_NIMP(lst) && SCM_CONSP (lst); lst = SCM_CDR(lst))
- {
- if (SCM_BOOL_F != scm_equal_p (SCM_CAR(lst), x))
- return lst;
- }
- return lst;
-}
-
-
-
-SCM_PROC(s_memq, "memq", 2, 0, 0, scm_memq);
-SCM
-scm_memq(x, lst)
- SCM x;
- SCM lst;
-{
- SCM answer;
- answer = scm_sloppy_memq (x, lst);
- sloppy_mem_check (answer, (char *)SCM_ARG2, s_memq);
- return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
-}
-
-
-
-SCM_PROC(s_memv, "memv", 2, 0, 0, scm_memv);
-SCM
-scm_memv(x, lst)
- SCM x;
- SCM lst;
-{
- SCM answer;
- answer = scm_sloppy_memv (x, lst);
- sloppy_mem_check (answer, (char *)SCM_ARG2, s_memv);
- return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
-}
-
-
-SCM_PROC(s_member, "member", 2, 0, 0, scm_member);
-SCM
-scm_member(x, lst)
- SCM x;
- SCM lst;
-{
- SCM answer;
- answer = scm_sloppy_member (x, lst);
- sloppy_mem_check (answer, (char *)SCM_ARG2, s_member);
- return (answer == SCM_EOL) ? SCM_BOOL_F : answer;
-}
-
-
-
-/* deleting elements from a list (delq, etc.) */
-
-SCM_PROC(s_delq_x, "delq!", 2, 0, 0, scm_delq_x);
-SCM
-scm_delq_x (item, lst)
- SCM item;
- SCM lst;
-{
- SCM start;
-
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return lst;
-
- if (SCM_CAR (lst) == item)
- return SCM_CDR (lst);
-
- start = lst;
-
- while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
- {
- if (SCM_CAR (SCM_CDR (lst)) == item)
- {
- SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
- return start;
- }
- lst = SCM_CDR (lst);
- }
- return start;
-}
-
-
-SCM_PROC(s_delv_x, "delv!", 2, 0, 0, scm_delv_x);
-SCM
-scm_delv_x (item, lst)
- SCM item;
- SCM lst;
-{
- SCM start;
-
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return lst;
-
- if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (lst), item))
- return SCM_CDR (lst);
-
- start = lst;
-
- while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
- {
- if (SCM_BOOL_F != scm_eqv_p (SCM_CAR (SCM_CDR (lst)), item))
- {
- SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
- return start;
- }
- lst = SCM_CDR (lst);
- }
- return start;
-}
-
-
-
-SCM_PROC(s_delete_x, "delete!", 2, 0, 0, scm_delete_x);
-SCM
-scm_delete_x (item, lst)
- SCM item;
- SCM lst;
-{
- SCM start;
-
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return lst;
-
- if (SCM_BOOL_F != scm_equal_p (SCM_CAR (lst), item))
- return SCM_CDR (lst);
-
- start = lst;
-
- while (SCM_NIMP (SCM_CDR (lst)) && SCM_CONSP (SCM_CDR (lst)))
- {
- if (SCM_BOOL_F != scm_equal_p (SCM_CAR (SCM_CDR (lst)), item))
- {
- SCM_SETCDR (lst, SCM_CDR (SCM_CDR (lst)));
- return start;
- }
- lst = SCM_CDR (lst);
- }
- return start;
-}
-
-
-
-
-
-SCM_PROC (s_delq, "delq", 2, 0, 0, scm_delq);
-SCM
-scm_delq (item, lst)
- SCM item;
- SCM lst;
-{
- SCM copy;
-
- copy = scm_list_copy (lst);
- return scm_delq_x (item, copy);
-}
-
-SCM_PROC (s_delv, "delv", 2, 0, 0, scm_delv);
-SCM
-scm_delv (item, lst)
- SCM item;
- SCM lst;
-{
- SCM copy;
-
- copy = scm_list_copy (lst);
- return scm_delv_x (item, copy);
-}
-
-SCM_PROC (s_delete, "delete", 2, 0, 0, scm_delete);
-SCM
-scm_delete (item, lst)
- SCM item;
- SCM lst;
-{
- SCM copy;
-
- copy = scm_list_copy (lst);
- return scm_delete_x (item, copy);
-}
-
-
-
-void
-scm_init_list ()
-{
-#include "list.x"
-}
diff --git a/libguile/list.h b/libguile/list.h
deleted file mode 100644
index 82d560673..000000000
--- a/libguile/list.h
+++ /dev/null
@@ -1,82 +0,0 @@
-/* classes: h_files */
-
-#ifndef LISTH
-#define LISTH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-extern SCM scm_list_head SCM_P ((SCM lst, SCM k));
-extern SCM scm_listify SCM_P ((SCM elt, ...));
-extern SCM scm_list SCM_P ((SCM objs));
-extern SCM scm_null_p SCM_P ((SCM x));
-extern SCM scm_list_p SCM_P ((SCM x));
-extern long scm_ilength SCM_P ((SCM sx));
-extern SCM scm_list_length SCM_P ((SCM x));
-extern SCM scm_list_append SCM_P ((SCM args));
-extern SCM scm_list_append_x SCM_P ((SCM args));
-extern SCM scm_list_reverse SCM_P ((SCM lst));
-extern SCM scm_list_reverse_x SCM_P ((SCM lst, SCM newtail));
-extern SCM scm_list_ref SCM_P ((SCM lst, SCM k));
-extern SCM scm_list_set_x SCM_P ((SCM lst, SCM k, SCM val));
-extern SCM scm_list_cdr_ref SCM_P ((SCM lst, SCM k));
-extern SCM scm_list_cdr_set_x SCM_P ((SCM lst, SCM k, SCM val));
-extern SCM scm_last_pair SCM_P ((SCM sx));
-extern SCM scm_list_tail SCM_P ((SCM lst, SCM k));
-extern SCM scm_sloppy_memq SCM_P ((SCM x, SCM lst));
-extern SCM scm_sloppy_memv SCM_P ((SCM x, SCM lst));
-extern SCM scm_sloppy_member SCM_P ((SCM x, SCM lst));
-extern SCM scm_memq SCM_P ((SCM x, SCM lst));
-extern SCM scm_memv SCM_P ((SCM x, SCM lst));
-extern SCM scm_member SCM_P ((SCM x, SCM lst));
-extern SCM scm_delq_x SCM_P ((SCM item, SCM lst));
-extern SCM scm_delv_x SCM_P ((SCM item, SCM lst));
-extern SCM scm_delete_x SCM_P ((SCM item, SCM lst));
-extern SCM scm_list_copy SCM_P ((SCM lst));
-extern SCM scm_delq SCM_P ((SCM item, SCM lst));
-extern SCM scm_delv SCM_P ((SCM item, SCM lst));
-extern SCM scm_delete SCM_P ((SCM item, SCM lst));
-extern void scm_init_list SCM_P ((void));
-
-#endif /* LISTH */
diff --git a/libguile/load.c b/libguile/load.c
deleted file mode 100644
index b9a9fc8cc..000000000
--- a/libguile/load.c
+++ /dev/null
@@ -1,343 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "libpath.h"
-#include "fports.h"
-#include "read.h"
-#include "eval.h"
-#include "throw.h"
-
-#include "load.h"
-
-#include <sys/types.h>
-#include <sys/stat.h>
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif /* HAVE_UNISTD_H */
-
-#ifndef R_OK
-#define R_OK 4
-#endif
-
-
-/* Loading a file, given an absolute filename. */
-
-/* Hook to run when we load a file, perhaps to announce the fact somewhere.
- Applied to the full name of the file. */
-static SCM *scm_loc_load_hook;
-
-SCM_PROC(s_primitive_load, "primitive-load", 1, 2, 0, scm_primitive_load);
-SCM
-scm_primitive_load (filename, case_insensitive_p, sharp)
- SCM filename;
- SCM case_insensitive_p;
- SCM sharp;
-{
- SCM hook = *scm_loc_load_hook;
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
- SCM_ARG1, s_primitive_load);
- SCM_ASSERT (hook == SCM_BOOL_F
- || (scm_procedure_p (hook) == SCM_BOOL_T),
- hook, "value of %load-hook is neither a procedure nor #f",
- s_primitive_load);
-
- if (hook != SCM_BOOL_F)
- scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL);
-
- {
- SCM form, port;
- port = scm_open_file (filename,
- scm_makfromstr ("r", (scm_sizet) sizeof (char), 0));
- while (1)
- {
- form = scm_read (port, case_insensitive_p, sharp);
- if (SCM_EOF_VAL == form)
- break;
- scm_eval_x (form);
- }
- scm_close_port (port);
- }
- return SCM_UNSPECIFIED;
-}
-
-
-/* Builtin path to scheme library files. */
-#ifdef SCM_PKGDATA_DIR
-SCM_PROC (s_sys_package_data_dir, "%package-data-dir", 0, 0, 0, scm_sys_package_data_dir);
-SCM
-scm_sys_package_data_dir ()
-{
- return scm_makfrom0str (SCM_PKGDATA_DIR);
-}
-#endif /* SCM_PKGDATA_DIR */
-
-
-/* Initializing the load path, and searching it. */
-
-/* List of names of directories we search for files to load. */
-static SCM *scm_loc_load_path;
-
-/* List of extensions we try adding to the filenames. */
-static SCM *scm_loc_load_extensions;
-
-/* Initialize the global variable %load-path, given the value of the
- SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
- SCHEME_LOAD_PATH environment variable. */
-void
-scm_init_load_path ()
-{
- SCM path = SCM_EOL;
-
-#ifdef SCM_LIBRARY_DIR
- path = scm_cons2 (scm_makfrom0str (SCM_SITE_DIR),
- scm_makfrom0str (SCM_LIBRARY_DIR),
- path);
-#endif /* SCM_LIBRARY_DIR */
-
- {
- char *path_string = getenv ("SCHEME_LOAD_PATH");
-
- if (path_string && path_string[0] != '\0')
- {
- char *scan, *elt_end;
-
- /* Scan backwards from the end of the string, to help
- construct the list in the right order. */
- scan = elt_end = path_string + strlen (path_string);
- do {
- /* Scan back to the beginning of the current element. */
- do scan--;
- while (scan >= path_string && *scan != ':');
- path = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0),
- path);
- elt_end = scan;
- } while (scan >= path_string);
- }
- }
-
- *scm_loc_load_path = path;
-}
-
-
-/* Search %load-path for a directory containing a file named FILENAME.
- The file must be readable, and not a directory.
- If we find one, return its full filename; otherwise, return #f.
- If FILENAME is absolute, return it unchanged. */
-SCM_PROC(s_sys_search_load_path, "%search-load-path", 1, 0, 0, scm_sys_search_load_path);
-SCM
-scm_sys_search_load_path (filename)
- SCM filename;
-{
- SCM path = *scm_loc_load_path;
- SCM exts = *scm_loc_load_extensions;
- char *buf;
- int filename_len;
- int max_path_len;
- int max_ext_len;
-
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
- SCM_ARG1, s_sys_search_load_path);
- SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list",
- s_sys_search_load_path);
- SCM_ASSERT (scm_ilength (exts) >= 0, exts,
- "load extension list is not a proper list",
- s_sys_search_load_path);
- filename_len = SCM_ROLENGTH (filename);
-
- /* If FILENAME is absolute, return it unchanged. */
- if (filename_len >= 1
- && SCM_ROCHARS (filename)[0] == '/')
- return filename;
-
- /* Find the length of the longest element of path. */
- {
- SCM walk;
-
- max_path_len = 0;
- for (walk = path; SCM_NIMP (walk); walk = SCM_CDR (walk))
- {
- SCM elt = SCM_CAR (walk);
- SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
- "load path is not a list of strings",
- s_sys_search_load_path);
- if (SCM_LENGTH (elt) > max_path_len)
- max_path_len = SCM_LENGTH (elt);
- }
- }
-
- /* Find the length of the longest element of the load extensions
- list. */
- {
- SCM walk;
-
- max_ext_len = 0;
- for (walk = exts; SCM_NIMP (walk); walk = SCM_CDR (walk))
- {
- SCM elt = SCM_CAR (walk);
- SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
- "load extension list is not a list of strings",
- s_sys_search_load_path);
- if (SCM_LENGTH (elt) > max_ext_len)
- max_ext_len = SCM_LENGTH (elt);
- }
- }
-
- SCM_DEFER_INTS;
-
- buf = scm_must_malloc (max_path_len + 1 + filename_len + max_ext_len + 1,
- s_sys_search_load_path);
-
- /* Try every path element. At this point, we know it's a proper
- list of strings. */
- for (; SCM_NIMP (path); path = SCM_CDR (path))
- {
- SCM path_elt = SCM_CAR (path);
-
- /* Try every extension. At this point, we know it's a proper
- list of strings. */
- for (exts = *scm_loc_load_extensions;
- SCM_NIMP (exts);
- exts = SCM_CDR (exts))
- {
- SCM ext_elt = SCM_CAR (exts);
- int i;
-
- /* Concatenate the path name, the filename, and the extension. */
- i = SCM_ROLENGTH (path_elt);
- memcpy (buf, SCM_ROCHARS (path_elt), i);
- if (i >= 1 && buf[i - 1] != '/')
- buf[i++] = '/';
- memcpy (buf + i, SCM_ROCHARS (filename), filename_len);
- i += filename_len;
- memcpy (buf + i, SCM_ROCHARS (ext_elt), SCM_LENGTH (ext_elt));
- i += SCM_LENGTH (ext_elt);
- buf[i] = '\0';
-
- {
- struct stat mode;
-
- if (stat (buf, &mode) >= 0
- && ! (mode.st_mode & S_IFDIR)
- && access (buf, R_OK) == 0)
- {
- SCM result = scm_makfromstr (buf, i, 0);
- scm_must_free (buf);
- SCM_ALLOW_INTS;
- return result;
- }
- }
- }
- }
-
- scm_must_free (buf);
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
-}
-
-
-SCM_PROC(s_primitive_load_path, "primitive-load-path", 1, 2, 0, scm_primitive_load_path);
-SCM
-scm_primitive_load_path (filename, case_insensitive_p, sharp)
- SCM filename;
- SCM case_insensitive_p;
- SCM sharp;
-{
- SCM full_filename;
-
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
- SCM_ARG1, s_primitive_load_path);
-
- full_filename = scm_sys_search_load_path (filename);
-
- if (SCM_FALSEP (full_filename))
- {
- int absolute = (SCM_LENGTH (filename) >= 1
- && SCM_ROCHARS (filename)[0] == '/');
- scm_misc_error (s_primitive_load_path,
- (absolute
- ? "Unable to load file %S"
- : "Unable to find file %S in load path"),
- scm_listify (filename, SCM_UNDEFINED));
- }
-
- return scm_primitive_load (full_filename, case_insensitive_p, sharp);
-}
-
-/* The following function seems trivial - and indeed it is. Its
- * existence is motivated by its ability to evaluate expressions
- * without copying them first (as is done in "eval").
- */
-
-SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
-
-SCM_PROC (s_read_and_eval_x, "read-and-eval!", 0, 3, 0, scm_read_and_eval_x);
-
-SCM
-scm_read_and_eval_x (port, case_insensitive_p, sharp)
- SCM port;
- SCM case_insensitive_p;
- SCM sharp;
-{
- SCM form = scm_read (port, case_insensitive_p, sharp);
- if (form == SCM_EOF_VAL)
- scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
- return scm_eval_x (form);
-}
-
-
-
-void
-scm_init_load ()
-{
- scm_loc_load_path = SCM_CDRLOC(scm_sysintern("%load-path", SCM_EOL));
- scm_loc_load_extensions
- = SCM_CDRLOC(scm_sysintern("%load-extensions",
- scm_listify (scm_makfrom0str (""),
- scm_makfrom0str (".scm"),
- SCM_UNDEFINED)));
- scm_loc_load_hook = SCM_CDRLOC(scm_sysintern("%load-hook", SCM_BOOL_F));
-
-#include "load.x"
-}
diff --git a/libguile/load.h b/libguile/load.h
deleted file mode 100644
index cd5d021bb..000000000
--- a/libguile/load.h
+++ /dev/null
@@ -1,60 +0,0 @@
-/* classes: h_files */
-
-#ifndef LOADH
-#define LOADH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-extern void scm_init_load_path SCM_P ((void));
-extern SCM scm_primitive_load SCM_P ((SCM filename, SCM casep, SCM sharp));
-extern SCM scm_sys_package_data_dir SCM_P ((void));
-extern SCM scm_sys_search_load_path SCM_P ((SCM filename));
-extern SCM scm_primitive_load_path SCM_P ((SCM filename, SCM casep,
- SCM sharp));
-extern SCM scm_read_and_eval_x SCM_P ((SCM port,
- SCM case_insensitive_p,
- SCM sharp));
-extern void scm_init_load SCM_P ((void));
-
-#endif /* LOADH */
diff --git a/libguile/mallocs.c b/libguile/mallocs.c
deleted file mode 100644
index 4201adca8..000000000
--- a/libguile/mallocs.c
+++ /dev/null
@@ -1,105 +0,0 @@
-/* classes: src_files */
-
-/* Copyright (C) 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- */
-
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "genio.h"
-#include "smob.h"
-
-#include "mallocs.h"
-
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-
-
-
-
-
-static scm_sizet fmalloc SCM_P ((SCM ptr));
-
-static scm_sizet
-fmalloc(ptr)
- SCM ptr;
-{
- if (SCM_MALLOCDATA (ptr))
- free (SCM_MALLOCDATA (ptr));
- return 0;
-}
-
-
-static int prinmalloc SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-
-static int
-prinmalloc (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_gen_puts(scm_regular_string, "#<malloc ", port);
- scm_intprint(SCM_CDR(exp), 16, port);
- scm_gen_putc('>', port);
- return 1;
-}
-
-
-int scm_tc16_malloc;
-static scm_smobfuns mallocsmob = {scm_mark0, fmalloc, prinmalloc, 0};
-
-
-
-
-SCM
-scm_malloc_obj (n)
- scm_sizet n;
-{
- SCM answer;
- SCM mem;
-
- SCM_NEWCELL (answer);
- SCM_DEFER_INTS;
- mem = (n
- ? (SCM)malloc (n)
- : 0);
- if (n && !mem)
- {
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
- }
- SCM_SETCDR (answer, mem);
- SCM_SETCAR (answer, scm_tc16_malloc);
- SCM_ALLOW_INTS;
- return answer;
-}
-
-
-
-
-void
-scm_init_mallocs ()
-{
- scm_tc16_malloc = scm_newsmob (&mallocsmob);
-}
-
diff --git a/libguile/mallocs.h b/libguile/mallocs.h
deleted file mode 100644
index 19fa8e5cd..000000000
--- a/libguile/mallocs.h
+++ /dev/null
@@ -1,60 +0,0 @@
-/* classes: h_files */
-
-#ifndef MALLOCSH
-#define MALLOCSH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-extern int scm_tc16_malloc;
-
-#define SCM_MALLOCP(X) (SCM_TYP16 (X) == scm_tc16_malloc)
-#define SCM_MALLOCDATA(obj) ((char *)SCM_CDR(obj))
-#define SCM_SETMALLOCDATA(obj, val) ((char *)SCM_SETCDR(obj, val))
-
-
-
-extern SCM scm_malloc_obj SCM_P ((scm_sizet n));
-extern void scm_init_mallocs SCM_P ((void));
-
-#endif /* MALLOCSH */
diff --git a/libguile/markers.c b/libguile/markers.c
deleted file mode 100644
index 2736b0df5..000000000
--- a/libguile/markers.c
+++ /dev/null
@@ -1,81 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-
-#include "markers.h"
-
-
-/* {GC marking}
- */
-
-
-SCM
-scm_mark0 (ptr)
- SCM ptr;
-{
- SCM_SETGC8MARK (ptr);
- return SCM_BOOL_F;
-}
-
-
-
-SCM
-scm_markcdr (ptr)
- SCM ptr;
-{
- if (SCM_GC8MARKP (ptr))
- return SCM_BOOL_F;
- SCM_SETGC8MARK (ptr);
- return SCM_CDR (ptr);
-}
-
-
-scm_sizet
-scm_free0 (ptr)
- SCM ptr;
-{
- return 0;
-}
-
-
diff --git a/libguile/markers.h b/libguile/markers.h
deleted file mode 100644
index 6a80e61a2..000000000
--- a/libguile/markers.h
+++ /dev/null
@@ -1,59 +0,0 @@
-/* classes: h_files */
-
-#ifndef MARKERSH
-#define MARKERSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-
-
-
-
-extern SCM scm_mark0 SCM_P ((SCM ptr));
-extern SCM scm_markcdr SCM_P ((SCM ptr));
-extern scm_sizet scm_free0 SCM_P ((SCM ptr));
-
-#endif /* MARKERSH */
diff --git a/libguile/mbstrings.c b/libguile/mbstrings.c
deleted file mode 100644
index 41e04bf80..000000000
--- a/libguile/mbstrings.c
+++ /dev/null
@@ -1,505 +0,0 @@
-
-
-/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-
-#include "extchrs.h"
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-#include "unif.h"
-#include "genio.h"
-#include "read.h"
-
-#include "mbstrings.h"
-
-
-SCM_PROC(s_multi_byte_string_p, "multi-byte-string?", 1, 0, 0, scm_multi_byte_string_p);
-
-SCM
-scm_multi_byte_string_p (obj)
- SCM obj;
-{
- return (SCM_MB_STRINGP (obj)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-
-SCM
-scm_regular_string_p (obj)
- SCM obj;
-{
- return (SCM_REGULAR_STRINGP (obj)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-SCM_PROC(s_list_to_multi_byte_string, "list->multi-byte-string", 1, 0, 0, scm_multi_byte_string);
-SCM_PROC(s_multi_byte_string, "multi-byte-string", 0, 0, 1, scm_multi_byte_string);
-
-SCM
-scm_multi_byte_string (chrs)
- SCM chrs;
-{
- SCM res;
- register char *data;
- long i;
- long byte_len;
-
- i = scm_ilength (chrs);
- SCM_ASSERT (i >= 0, chrs, SCM_ARG1, s_multi_byte_string);
- i = i * XMB_CUR_MAX;
- res = scm_makstr (i, 0);
- SCM_SETLENGTH (res, SCM_LENGTH (res), scm_tc7_mb_string);
- data = SCM_CHARS (res);
- byte_len = 0;
- xwctomb (0, 0);
- while (i && SCM_NNULLP (chrs))
- {
- int used;
- SCM ch;
-
- ch = SCM_CAR (chrs);
- SCM_ASSERT (SCM_ICHRP (ch), chrs, SCM_ARG1, s_multi_byte_string);
- used = xwctomb (data + byte_len, SCM_ICHR (ch));
- SCM_ASSERT (used >= 0, chrs, SCM_ARG1, s_multi_byte_string);
- byte_len += (used ? used : 1);
- chrs = SCM_CDR (chrs);
- --i;
- }
- res = scm_vector_set_length_x (res, SCM_MAKINUM (byte_len));
- return res;
-}
-
-
-int
-scm_mb_ilength (data, size)
- unsigned char * data;
- int size;
-{
- int pos;
- int len;
-
- len = 0;
- pos = 0;
- xmblen (0, 0);
- while (pos < size)
- {
- int inc;
-
- inc = xmblen (data + pos, size - pos);
- if (inc == 0)
- ++inc;
-
- if (inc < 0)
- return -1;
-
- ++len;
- pos += inc;
- }
-
- return len;
-}
-
-SCM_PROC(s_multi_byte_string_length, "multi-byte-string-length", 1, 0, 0, scm_multi_byte_string_length);
-
-SCM
-scm_multi_byte_string_length (str)
- SCM str;
-{
- int size;
- int len;
- unsigned char * data;
-
- SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_multi_byte_string_length);
-
- data = SCM_ROCHARS (str);
- size = SCM_ROLENGTH (str);
- len = scm_mb_ilength (data, size);
- SCM_ASSERT (len >= 0, str, SCM_ARG1, s_multi_byte_string_length);
- return SCM_MAKINUM (len);
-}
-
-
-SCM_PROC(s_symbol_multi_byte_p, "symbol-multi-byte?", 1, 0, 0, scm_symbol_multi_byte_p);
-
-SCM
-scm_symbol_multi_byte_p (symbol)
- SCM symbol;
-{
- return SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol);
-}
-
-SCM_PROC(s_set_symbol_multi_byte_x, "set-symbol-multi-byte!", 2, 0, 0, scm_set_symbol_multi_byte_x);
-
-SCM
-scm_set_symbol_multi_byte_x (symbol, val)
- SCM symbol;
- SCM val;
-{
- if (SCM_TYP7 (symbol) == scm_tc7_msymbol)
- {
- SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol) = (SCM_FALSEP (val)
- ? SCM_BOOL_F
- : SCM_BOOL_T);
- }
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_regular_port_p, "regular-port?", 1, 0, 0, scm_regular_port_p);
-
-SCM
-scm_regular_port_p (p)
- SCM p;
-{
- return (SCM_PORT_REPRESENTATION(p) == scm_regular_port
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-SCM_PROC(s_regular_port_x, "regular-port!", 1, 0, 0, scm_regular_port_x);
-
-SCM
-scm_regular_port_x (p)
- SCM p;
-{
- SCM_PORT_REPRESENTATION(p) = scm_regular_port;
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC(s_multi_byte_port_p, "multi-byte-port?", 1, 0, 0, scm_multi_byte_port_p);
-
-SCM
-scm_multi_byte_port_p (p)
- SCM p;
-{
- return (SCM_PORT_REPRESENTATION(p) == scm_mb_port
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-SCM_PROC(s_multi_byte_port_x, "multi-byte-port!", 1, 0, 0, scm_multi_byte_port_x);
-
-SCM
-scm_multi_byte_port_x (p)
- SCM p;
-{
- SCM_PORT_REPRESENTATION(p) = scm_mb_port;
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_wide_character_port_p, "wide-character-port?", 1, 0, 0, scm_wide_character_port_p);
-
-SCM
-scm_wide_character_port_p (p)
- SCM p;
-{
- return (SCM_PORT_REPRESENTATION(p) == scm_wchar_port
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-SCM_PROC(s_wide_character_port_x, "wide-character-port!", 1, 0, 0, scm_wide_character_port_x);
-
-SCM
-scm_wide_character_port_x (p)
- SCM p;
-{
- SCM_PORT_REPRESENTATION(p) = scm_wchar_port;
- return SCM_UNSPECIFIED;
-}
-
-
-
-
-
-
-void
-scm_put_wchar (c, port, writing)
- int c;
- SCM port;
- int writing;
-{
- if (writing)
- scm_gen_puts (scm_regular_string, "#\\", port);
- switch (SCM_PORT_REPRESENTATION (port))
- {
- case scm_regular_port:
- {
- if (c < 256)
- {
- if (!writing)
- scm_gen_putc ((unsigned char)c, port);
- else if ((c <= ' ') && scm_charnames[c])
- scm_gen_puts (scm_regular_string, scm_charnames[c], port);
- else if (c > '\177')
- scm_intprint (c, 8, port);
- else
- scm_gen_putc ((int) c, port);
- }
- else
- {
- print_octal:
- if (!writing)
- scm_gen_putc ('\\', port);
- scm_intprint (c, 8, port);
- }
- break;
- }
-
- case scm_mb_port:
- {
- char buf[256];
- int len;
-
- if (XMB_CUR_MAX > sizeof (buf))
- goto print_octal;
-
- len = xwctomb (buf, c);
-
- if (len < 0)
- goto print_octal;
-
- if (len == 0)
- scm_gen_putc (0, port);
- else
- scm_gen_putc (c, port);
- break;
- }
-
- case scm_wchar_port:
- {
- scm_gen_putc (c, port);
- break;
- }
- }
-}
-
-
-
-
-
-
-void
-scm_print_mb_string (exp, port, writing)
- SCM exp;
- SCM port;
- int writing;
-{
- if (writing)
- {
- int i;
- int len;
- char * data;
-
- scm_gen_putc ('\"', port);
- i = 0;
- len = SCM_ROLENGTH (exp);
- data = SCM_ROCHARS (exp);
-
- while (i < len)
- {
- xwchar_t c;
- int inc;
-
- inc = xmbtowc (&c, data + i, len - i);
- if (inc == 0)
- inc = 1;
- if (inc < 0)
- {
- inc = 1;
- c = data[i];
- }
- i += inc;
- switch (c)
- {
- case '\"':
- case '\\':
- scm_gen_putc ('\\', port);
- default:
- scm_gen_putc (c, port);
- }
- }
- scm_gen_putc ('\"', port);
- }
- else
- scm_gen_write (scm_mb_string, SCM_ROCHARS (exp), SCM_ROLENGTH (exp), port);
-}
-
-
-
-void
-scm_print_mb_symbol (exp, port)
- SCM exp;
- SCM port;
-{
- int pos;
- int end;
- int len;
- char * str;
- int weird;
- int maybe_weird;
- int mw_pos = 0; /* initialized to placate compiler */
- int inc = 0; /* same */
- xwchar_t c;
-
- len = SCM_LENGTH (exp);
- str = SCM_CHARS (exp);
- scm_remember (&exp);
- pos = 0;
- weird = 0;
- maybe_weird = 0;
-
- for (end = pos; end < len; end += inc)
- {
- inc = xmbtowc (&c, str + end, len - end);
- if (inc < 0)
- {
- inc = 1;
- c = str[end];
- goto weird_handler;
- }
- if (inc == 0)
- {
- inc = 1;
- goto weird_handler;
- }
- switch (c)
- {
-#ifdef BRACKETS_AS_PARENS
- case '[':
- case ']':
-#endif
- case '(':
- case ')':
- case '\"':
- case ';':
- case SCM_WHITE_SPACES:
- case SCM_LINE_INCREMENTORS:
- weird_handler:
- if (maybe_weird)
- {
- end = mw_pos;
- maybe_weird = 0;
- }
- if (!weird)
- {
- scm_gen_write (scm_regular_string, "#{", 2, port);
- weird = 1;
- }
- if (pos < end)
- {
- int q;
- int qinc;
-
- q = pos;
- while (q < end)
- {
- qinc = xmbtowc (&c, str + q, end - q);
- if (inc <= 0)
- {
- inc = 1;
- c = str[q];
- }
- scm_gen_putc (c, port);
- q += qinc;
- }
- }
- {
- char buf[2];
- buf[0] = '\\';
- buf[1] = str[end];
- scm_gen_write (scm_regular_string, buf, 2, port);
- }
- pos = end + 1;
- break;
- case '\\':
- if (weird)
- goto weird_handler;
- if (!maybe_weird)
- {
- maybe_weird = 1;
- mw_pos = pos;
- }
- break;
- case '}':
- case '#':
- if (weird)
- goto weird_handler;
- break;
- default:
- break;
- }
- }
- if (pos < end)
- {
- int q;
- int qinc;
- q = pos;
- while (q < end)
- {
- qinc = xmbtowc (&c, str + q, end - q);
- if (inc <= 0)
- inc = 1;
- scm_gen_putc (c, port);
- q += qinc;
- }
- }
- if (weird)
- scm_gen_write (scm_regular_string, "}#", 2, port);
-}
-
-
-
-
-
-void
-scm_init_mbstrings ()
-{
-#include "mbstrings.x"
-}
-
diff --git a/libguile/mbstrings.h b/libguile/mbstrings.h
deleted file mode 100644
index 84482c5a8..000000000
--- a/libguile/mbstrings.h
+++ /dev/null
@@ -1,78 +0,0 @@
-/* classes: h_files */
-
-#ifndef MBSTRINGSH
-#define MBSTRINGSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-#include "libguile/symbols.h"
-
-
-#define SCM_MB_STRINGP(x) ( (SCM_TYP7(x)==scm_tc7_mb_string) \
- || ( (SCM_TYP7(x) == scm_tc7_msymbol) \
- && (SCM_SYMBOL_MULTI_BYTE_STRINGP (x) != SCM_BOOL_F)))
-#define SCM_REGULAR_STRINGP(x) (SCM_TYP7D(x)==scm_tc7_string)
-
-
-
-
-
-extern SCM scm_multi_byte_string_p SCM_P ((SCM obj));
-extern SCM scm_regular_string_p SCM_P ((SCM obj));
-extern SCM scm_multi_byte_string SCM_P ((SCM chrs));
-extern int scm_mb_ilength SCM_P ((unsigned char * data, int size));
-extern SCM scm_multi_byte_string_length SCM_P ((SCM str));
-extern SCM scm_symbol_multi_byte_p SCM_P ((SCM symbol));
-extern SCM scm_set_symbol_multi_byte_x SCM_P ((SCM symbol, SCM val));
-extern SCM scm_regular_port_p SCM_P ((SCM p));
-extern SCM scm_regular_port_x SCM_P ((SCM p));
-extern SCM scm_multi_byte_port_p SCM_P ((SCM p));
-extern SCM scm_multi_byte_port_x SCM_P ((SCM p));
-extern SCM scm_wide_character_port_p SCM_P ((SCM p));
-extern SCM scm_wide_character_port_x SCM_P ((SCM p));
-extern void scm_put_wchar SCM_P ((int c, SCM port, int writing));
-extern void scm_print_mb_string SCM_P ((SCM exp, SCM port, int writing));
-extern void scm_print_mb_symbol SCM_P ((SCM exp, SCM port));
-extern void scm_init_mbstrings SCM_P ((void));
-
-#endif /* MBSTRINGSH */
diff --git a/libguile/numbers.c b/libguile/numbers.c
deleted file mode 100644
index 360527611..000000000
--- a/libguile/numbers.c
+++ /dev/null
@@ -1,3704 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include <math.h>
-#include "_scm.h"
-#include "genio.h"
-#include "unif.h"
-
-#include "numbers.h"
-
-#define DIGITS '0':case '1':case '2':case '3':case '4':\
- case '5':case '6':case '7':case '8':case '9'
-
-
-/* IS_INF tests its floating point number for infiniteness
- */
-#ifndef IS_INF
-# define IS_INF(x) ((x)==(x)/2)
-#endif
-
-/* MAXEXP is the maximum double precision expontent
- * FLTMAX is less than or scm_equal the largest single precision float
- */
-
-#ifdef SCM_FLOATS
-# ifdef STDC_HEADERS
-# ifndef GO32
-# include <float.h>
-# endif /* ndef GO32 */
-# endif /* def STDC_HEADERS */
-# ifdef DBL_MAX_10_EXP
-# define MAXEXP DBL_MAX_10_EXP
-# else
-# define MAXEXP 308 /* IEEE doubles */
-# endif /* def DBL_MAX_10_EXP */
-# ifdef FLT_MAX
-# define FLTMAX FLT_MAX
-# else
-# define FLTMAX 1e+23
-# endif /* def FLT_MAX */
-#endif /* def SCM_FLOATS */
-
-
-
-SCM_PROC(s_exact_p, "exact?", 1, 0, 0, scm_exact_p);
-
-SCM
-scm_exact_p(x)
- SCM x;
-{
- if SCM_INUMP(x) return SCM_BOOL_T;
-#ifdef SCM_BIGDIG
- if (SCM_NIMP(x) && SCM_BIGP(x)) return SCM_BOOL_T;
-#endif
- return SCM_BOOL_F;
-}
-
-SCM_PROC(s_odd_p, "odd?", 1, 0, 0, scm_odd_p);
-
-SCM
-scm_odd_p(n)
- SCM n;
-{
-#ifdef SCM_BIGDIG
- if SCM_NINUMP(n) {
- SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_odd_p);
- return (1 & SCM_BDIGITS(n)[0]) ? SCM_BOOL_T : SCM_BOOL_F;
- }
-#else
- SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_odd_p);
-#endif
- return (4 & (int)n) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_even_p, "even?", 1, 0, 0, scm_even_p);
-
-SCM
-scm_even_p(n)
- SCM n;
-{
-#ifdef SCM_BIGDIG
- if SCM_NINUMP(n) {
- SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_even_p);
- return (1 & SCM_BDIGITS(n)[0]) ? SCM_BOOL_F : SCM_BOOL_T;
- }
-#else
- SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_even_p);
-#endif
- return (4 & (int)n) ? SCM_BOOL_F : SCM_BOOL_T;
-}
-
-SCM_PROC(s_abs, "abs", 1, 0, 0, scm_abs);
-
-SCM
-scm_abs(x)
- SCM x;
-{
-#ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_abs);
- if (SCM_TYP16(x)==scm_tc16_bigpos) return x;
- return scm_copybig(x, 0);
- }
-#else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_abs);
-#endif
- if (SCM_INUM(x) >= 0) return x;
- x = -SCM_INUM(x);
- if (!SCM_POSFIXABLE(x))
-#ifdef SCM_BIGDIG
- return scm_long2big(x);
-#else
- scm_num_overflow (s_abs);
-#endif
- return SCM_MAKINUM(x);
-}
-
-SCM_PROC(s_quotient, "quotient", 2, 0, 0, scm_quotient);
-
-SCM
-scm_quotient(x, y)
- SCM x;
- SCM y;
-{
- register long z;
-#ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- long w;
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_quotient);
- if SCM_NINUMP(y) {
- SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
- return scm_divbigbig(SCM_BDIGITS(x),
- SCM_NUMDIGS(x),
- SCM_BDIGITS(y),
- SCM_NUMDIGS(y),
- SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y),
- 2);
- }
- z = SCM_INUM(y);
- SCM_ASRTGO(z, ov);
- if (1==z) return x;
- if (z < 0) z = -z;
- if (z < SCM_BIGRAD) {
- w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0));
- scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z);
- return scm_normbig(w);
- }
-#ifndef SCM_DIGSTOOBIG
- w = scm_pseudolong(z);
- return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&w, SCM_DIGSPERLONG,
- SCM_BIGSIGN(x) ? (y>0) : (y<0), 2);
-#else
- { SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
- scm_longdigs(z, zdigs);
- return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG,
- SCM_BIGSIGN(x) ? (y>0) : (y<0), 2);
- }
-#endif
- }
- if SCM_NINUMP(y) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_BIGP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_quotient);
-# endif
- return SCM_INUM0;
- }
-#else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_quotient);
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_quotient);
-#endif
- if ((z = SCM_INUM(y))==0)
- ov: scm_num_overflow (s_quotient);
- z = SCM_INUM(x)/z;
-#ifdef BADIVSGNS
- {
-#if (__TURBOC__==1)
- long t = ((y<0) ? -SCM_INUM(x) : SCM_INUM(x))%SCM_INUM(y);
-#else
- long t = SCM_INUM(x)%SCM_INUM(y);
-#endif
- if (t==0) ;
- else if (t < 0)
- if (x < 0) ;
- else z--;
- else if (x < 0) z++;
- }
-#endif
- if (!SCM_FIXABLE(z))
-#ifdef SCM_BIGDIG
- return scm_long2big(z);
-#else
- scm_num_overflow (s_quotient);
-#endif
- return SCM_MAKINUM(z);
-}
-
-SCM_PROC(s_remainder, "remainder", 2, 0, 0, scm_remainder);
-
-SCM
-scm_remainder(x, y)
- SCM x;
- SCM y;
-{
- register long z;
-#ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_remainder);
- if SCM_NINUMP(y) {
- SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
- return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
- SCM_BIGSIGN(x), 0);
- }
- if (!(z = SCM_INUM(y))) goto ov;
- return scm_divbigint(x, z, SCM_BIGSIGN(x), 0);
- }
- if SCM_NINUMP(y) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_BIGP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_remainder);
-# endif
- return x;
- }
-#else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_remainder);
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_remainder);
-#endif
- if (!(z = SCM_INUM(y)))
- ov: scm_num_overflow (s_remainder);
-#if (__TURBOC__==1)
- if (z < 0) z = -z;
-#endif
- z = SCM_INUM(x)%z;
-#ifdef BADIVSGNS
- if (!z) ;
- else if (z < 0)
- if (x < 0) ;
- else z += SCM_INUM(y);
- else if (x < 0) z -= SCM_INUM(y);
-#endif
- return SCM_MAKINUM(z);
-}
-
-SCM_PROC(s_modulo, "modulo", 2, 0, 0, scm_modulo);
-
-SCM
-scm_modulo(x, y)
- SCM x;
- SCM y;
-{
- register long yy, z;
-#ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_modulo);
- if SCM_NINUMP(y) {
- SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
- return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
- SCM_BIGSIGN(y), (SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y)) ? 1 : 0);
- }
- if (!(z = SCM_INUM(y))) goto ov;
- return scm_divbigint(x, z, y < 0, (SCM_BIGSIGN(x) ? (y > 0) : (y < 0)) ? 1 : 0);
- }
- if SCM_NINUMP(y) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_BIGP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_modulo);
-# endif
- return (SCM_BIGSIGN(y) ? (x>0) : (x<0)) ? scm_sum(x, y) : x;
- }
-#else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_modulo);
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_modulo);
-#endif
- if (!(yy = SCM_INUM(y)))
- ov: scm_num_overflow (s_modulo);
-#if (__TURBOC__==1)
- z = SCM_INUM(x);
- z = ((yy<0) ? -z : z)%yy;
-#else
- z = SCM_INUM(x)%yy;
-#endif
- return SCM_MAKINUM(((yy<0) ? (z>0) : (z<0)) ? z+yy : z);
-}
-
-SCM_PROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd);
-
-SCM
-scm_gcd(x, y)
- SCM x;
- SCM y;
-{
- register long u, v, k, t;
- if SCM_UNBNDP(y) return SCM_UNBNDP(x) ? SCM_INUM0 : x;
- tailrec:
-#ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- big_gcd:
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_gcd);
- if SCM_BIGSIGN(x) x = scm_copybig(x, 0);
- newy:
- if SCM_NINUMP(y) {
- SCM_ASSERT(SCM_NIMP(y) && SCM_BIGP(y), y, SCM_ARG2, s_gcd);
- if SCM_BIGSIGN(y) y = scm_copybig(y, 0);
- switch (scm_bigcomp(x, y)) {
- case -1:
- swaprec: t = scm_remainder(x, y); x = y; y = t; goto tailrec;
- case 0: return x;
- case 1: y = scm_remainder(y, x); goto newy;
- }
- /* instead of the switch, we could just return scm_gcd(y, scm_modulo(x, y)); */
- }
- if (SCM_INUM0==y) return x; goto swaprec;
- }
- if SCM_NINUMP(y) { t=x; x=y; y=t; goto big_gcd;}
-#else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_gcd);
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_gcd);
-#endif
- u = SCM_INUM(x);
- if (u<0) u = -u;
- v = SCM_INUM(y);
- if (v<0) v = -v;
- else if (0==v) goto getout;
- if (0==u) {u = v; goto getout;}
- for (k = 1;!(1 & ((int)u|(int)v));k <<= 1, u >>= 1, v >>= 1);
- if (1 & (int)u) t = -v;
- else {
- t = u;
- b3:
- t = SCM_SRS(t, 1);
- }
- if (!(1 & (int)t)) goto b3;
- if (t>0) u = t;
- else v = -t;
- if ((t = u-v)) goto b3;
- u = u*k;
- getout:
- if (!SCM_POSFIXABLE(u))
-#ifdef SCM_BIGDIG
- return scm_long2big(u);
-#else
- scm_num_overflow (s_gcd);
-#endif
- return SCM_MAKINUM(u);
-}
-
-SCM_PROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm);
-
-SCM
-scm_lcm(n1, n2)
- SCM n1;
- SCM n2;
-{
- SCM d;
- if SCM_UNBNDP(n2) {
- n2 = SCM_MAKINUM(1L);
- if SCM_UNBNDP(n1) return n2;
- }
- d = scm_gcd(n1, n2);
- if (SCM_INUM0==d) return d;
- return scm_abs(scm_product(n1, scm_quotient(n2, d)));
-}
-
-#ifndef SCM_BIGDIG
-# ifndef SCM_FLOATS
-# define scm_long2num SCM_MAKINUM
-# endif
-#endif
-
-#ifndef scm_long2num
-SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand);
-
-SCM
-scm_logand(n1, n2)
- SCM n1;
- SCM n2;
-{
- return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logand)
- & scm_num2long(n2, (char *)SCM_ARG2, s_logand));
-}
-
-SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior);
-
-SCM
-scm_logior(n1, n2)
- SCM n1;
- SCM n2;
-{
- return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logior)
- | scm_num2long(n2, (char *)SCM_ARG2, s_logior));
-}
-
-SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor);
-
-SCM
-scm_logxor(n1, n2)
- SCM n1;
- SCM n2;
-{
- return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logxor)
- ^ scm_num2long(n2, (char *)SCM_ARG2, s_logxor));
-}
-
-SCM_PROC(s_logtest, "logtest", 2, 0, 0, scm_logtest);
-
-SCM
-scm_logtest(n1, n2)
- SCM n1;
- SCM n2;
-{
- return ((scm_num2long (n1, (char *)SCM_ARG1, s_logtest)
- & scm_num2long (n2, (char *)SCM_ARG2, s_logtest))
- ? SCM_BOOL_T : SCM_BOOL_F);
-}
-
-
-SCM_PROC(s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p);
-
-SCM
-scm_logbit_p(n1, n2)
- SCM n1;
- SCM n2;
-{
- return (((1 << scm_num2long (n1, (char *)SCM_ARG1, s_logtest))
- & scm_num2long (n2, (char *)SCM_ARG2, s_logtest))
- ? SCM_BOOL_T : SCM_BOOL_F);
-}
-
-#else
-
-SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand);
-
-SCM
-scm_logand(n1, n2)
- SCM n1;
- SCM n2;
-{
- SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logand);
- SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logand);
- return SCM_MAKINUM(SCM_INUM(n1) & SCM_INUM(n2));
-}
-
-SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior);
-
-SCM
-scm_logior(n1, n2)
- SCM n1;
- SCM n2;
-{
- SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logior);
- SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logior);
- return SCM_MAKINUM(SCM_INUM(n1) | SCM_INUM(n2));
-}
-
-SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor);
-
-SCM
-scm_logxor(n1, n2)
- SCM n1;
- SCM n2;
-{
- SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logxor);
- SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logxor);
- return SCM_MAKINUM(SCM_INUM(n1) ^ SCM_INUM(n2));
-}
-
-SCM_PROC(s_logtest, "logtest", 2, 0, 0, scm_logtest);
-
-SCM
-scm_logtest(n1, n2)
- SCM n1;
- SCM n2;
-{
- SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logtest);
- SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logtest);
- return (SCM_INUM(n1) & SCM_INUM(n2)) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p);
-
-SCM
-scm_logbit_p(n1, n2)
- SCM n1;
- SCM n2;
-{
- SCM_ASSERT(SCM_INUMP(n1) && SCM_INUM(n1) >= 0, n1, SCM_ARG1, s_logbit_p);
- SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logbit_p);
- return ((1 << SCM_INUM(n1)) & SCM_INUM(n2)) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-#endif
-
-SCM_PROC(s_lognot, "lognot", 1, 0, 0, scm_lognot);
-
-SCM
-scm_lognot(n)
- SCM n;
-{
- SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_lognot);
- return scm_difference(SCM_MAKINUM(-1L), n);
-}
-
-SCM_PROC(s_integer_expt, "integer-expt", 2, 0, 0, scm_integer_expt);
-
-SCM
-scm_integer_expt(z1, z2)
- SCM z1;
- SCM z2;
-{
- SCM acc = SCM_MAKINUM(1L);
-#ifdef SCM_BIGDIG
- if (SCM_INUM0==z1 || acc==z1) return z1;
- else if (SCM_MAKINUM(-1L)==z1) return SCM_BOOL_F==scm_even_p(z2)?z1:acc;
-#endif
- SCM_ASSERT(SCM_INUMP(z2), z2, SCM_ARG2, s_integer_expt);
- z2 = SCM_INUM(z2);
- if (z2 < 0) {
- z2 = -z2;
- z1 = scm_divide(z1, SCM_UNDEFINED);
- }
- while(1) {
- if (0==z2) return acc;
- if (1==z2) return scm_product(acc, z1);
- if (z2 & 1) acc = scm_product(acc, z1);
- z1 = scm_product(z1, z1);
- z2 >>= 1;
- }
-}
-
-SCM_PROC(s_ash, "ash", 2, 0, 0, scm_ash);
-
-SCM
-scm_ash(n, cnt)
- SCM n;
- SCM cnt;
-{
- SCM res = SCM_INUM(n);
- SCM_ASSERT(SCM_INUMP(cnt), cnt, SCM_ARG2, s_ash);
-#ifdef SCM_BIGDIG
- if(cnt < 0) {
- res = scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(-SCM_INUM(cnt)));
- if (SCM_NFALSEP(scm_negative_p(n)))
- return scm_sum(SCM_MAKINUM(-1L), scm_quotient(scm_sum(SCM_MAKINUM(1L), n), res));
- else return scm_quotient(n, res);
- }
- else return scm_product(n, scm_integer_expt(SCM_MAKINUM(2), cnt));
-#else
- SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_ash);
- cnt = SCM_INUM(cnt);
- if (cnt < 0) return SCM_MAKINUM(SCM_SRS(res, -cnt));
- res = SCM_MAKINUM(res<<cnt);
- if (SCM_INUM(res)>>cnt != SCM_INUM(n))
- scm_num_overflow (s_ash);
- return res;
-#endif
-}
-
-SCM_PROC(s_bit_extract, "bit-extract", 3, 0, 0, scm_bit_extract);
-
-SCM
-scm_bit_extract(n, start, end)
- SCM n;
- SCM start;
- SCM end;
-{
- SCM_ASSERT(SCM_INUMP(start), start, SCM_ARG2, s_bit_extract);
- SCM_ASSERT(SCM_INUMP(end), end, SCM_ARG3, s_bit_extract);
- start = SCM_INUM(start); end = SCM_INUM(end);
- SCM_ASSERT(end >= start, SCM_MAKINUM(end), SCM_OUTOFRANGE, s_bit_extract);
-#ifdef SCM_BIGDIG
- if SCM_NINUMP(n)
- return
- scm_logand(scm_difference(scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(end - start)),
- SCM_MAKINUM(1L)),
- scm_ash(n, SCM_MAKINUM(-start)));
-#else
- SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_bit_extract);
-#endif
- return SCM_MAKINUM((SCM_INUM(n)>>start) & ((1L<<(end-start))-1));
-}
-
-char scm_logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
-SCM_PROC(s_logcount, "logcount", 1, 0, 0, scm_logcount);
-
-SCM
-scm_logcount(n)
- SCM n;
-{
- register unsigned long c = 0;
- register long nn;
-#ifdef SCM_BIGDIG
- if SCM_NINUMP(n) {
- scm_sizet i; SCM_BIGDIG *ds, d;
- SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_logcount);
- if SCM_BIGSIGN(n) return scm_logcount(scm_difference(SCM_MAKINUM(-1L), n));
- ds = SCM_BDIGITS(n);
- for(i = SCM_NUMDIGS(n); i--; )
- for(d = ds[i]; d; d >>= 4) c += scm_logtab[15 & d];
- return SCM_MAKINUM(c);
- }
-#else
- SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_logcount);
-#endif
- if ((nn = SCM_INUM(n)) < 0) nn = -1 - nn;
- for(; nn; nn >>= 4) c += scm_logtab[15 & nn];
- return SCM_MAKINUM(c);
-}
-
-char scm_ilentab[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4};
-SCM_PROC(s_integer_length, "integer-length", 1, 0, 0, scm_integer_length);
-
-SCM
-scm_integer_length(n)
- SCM n;
-{
- register unsigned long c = 0;
- register long nn;
- unsigned int l = 4;
-#ifdef SCM_BIGDIG
- if SCM_NINUMP(n) {
- SCM_BIGDIG *ds, d;
- SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_integer_length);
- if SCM_BIGSIGN(n) return scm_integer_length(scm_difference(SCM_MAKINUM(-1L), n));
- ds = SCM_BDIGITS(n);
- d = ds[c = SCM_NUMDIGS(n)-1];
- for(c *= SCM_BITSPERDIG; d; d >>= 4) {c += 4; l = scm_ilentab[15 & d];}
- return SCM_MAKINUM(c - 4 + l);
- }
-#else
- SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_integer_length);
-#endif
- if ((nn = SCM_INUM(n)) < 0) nn = -1 - nn;
- for(;nn; nn >>= 4) {c += 4; l = scm_ilentab[15 & nn];}
- return SCM_MAKINUM(c - 4 + l);
-}
-
-
-#ifdef SCM_BIGDIG
-char s_bignum[] = "bignum";
-
-SCM
-scm_mkbig(nlen, sign)
- scm_sizet nlen;
- int sign;
-{
- SCM v = nlen;
- if (((v << 16) >> 16) != nlen)
- scm_wta(SCM_MAKINUM(nlen), (char *)SCM_NALLOC, s_bignum);
- SCM_NEWCELL(v);
- SCM_DEFER_INTS;
- SCM_SETCHARS(v, scm_must_malloc((long)(nlen*sizeof(SCM_BIGDIG)), s_bignum));
- SCM_SETNUMDIGS(v, nlen, sign?scm_tc16_bigneg:scm_tc16_bigpos);
- SCM_ALLOW_INTS;
- return v;
-}
-
-
-SCM
-scm_big2inum(b, l)
- SCM b;
- scm_sizet l;
-{
- unsigned long num = 0;
- SCM_BIGDIG *tmp = SCM_BDIGITS(b);
- while (l--) num = SCM_BIGUP(num) + tmp[l];
- if (SCM_TYP16(b)==scm_tc16_bigpos) {
- if SCM_POSFIXABLE(num) return SCM_MAKINUM(num);
- }
- else if SCM_UNEGFIXABLE(num) return SCM_MAKINUM(-num);
- return b;
-}
-
-
-char s_adjbig[] = "scm_adjbig";
-
-SCM
-scm_adjbig(b, nlen)
- SCM b;
- scm_sizet nlen;
-{
- long nsiz = nlen;
- if (((nsiz << 16) >> 16) != nlen) scm_wta(SCM_MAKINUM(nsiz), (char *)SCM_NALLOC, s_adjbig);
- SCM_DEFER_INTS;
- SCM_SETCHARS(b, (SCM_BIGDIG *)scm_must_realloc((char *)SCM_CHARS(b),
- (long)(SCM_NUMDIGS(b)*sizeof(SCM_BIGDIG)),
- (long)(nsiz*sizeof(SCM_BIGDIG)), s_adjbig));
- SCM_SETNUMDIGS(b, nsiz, SCM_TYP16(b));
- SCM_ALLOW_INTS;
- return b;
-}
-
-
-
-SCM
-scm_normbig(b)
- SCM b;
-{
-#ifndef _UNICOS
- scm_sizet nlen = SCM_NUMDIGS(b);
-#else
- int nlen = SCM_NUMDIGS(b); /* unsigned nlen breaks on Cray when nlen => 0 */
-#endif
- SCM_BIGDIG *zds = SCM_BDIGITS(b);
- while (nlen-- && !zds[nlen]); nlen++;
- if (nlen * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM))
- if SCM_INUMP(b = scm_big2inum(b, (scm_sizet)nlen)) return b;
- if (SCM_NUMDIGS(b)==nlen) return b;
- return scm_adjbig(b, (scm_sizet)nlen);
-}
-
-
-
-SCM
-scm_copybig(b, sign)
- SCM b;
- int sign;
-{
- scm_sizet i = SCM_NUMDIGS(b);
- SCM ans = scm_mkbig(i, sign);
- SCM_BIGDIG *src = SCM_BDIGITS(b), *dst = SCM_BDIGITS(ans);
- while (i--) dst[i] = src[i];
- return ans;
-}
-
-
-
-SCM
-scm_long2big(n)
- long n;
-{
- scm_sizet i = 0;
- SCM_BIGDIG *digits;
- SCM ans = scm_mkbig(SCM_DIGSPERLONG, n<0);
- digits = SCM_BDIGITS(ans);
- if (n < 0) n = -n;
- while (i < SCM_DIGSPERLONG) {
- digits[i++] = SCM_BIGLO(n);
- n = SCM_BIGDN((unsigned long)n);
- }
- return ans;
-}
-
-#ifdef LONGLONGS
-
-SCM
-scm_long_long2big(n)
- long_long n;
-{
- scm_sizet i;
- SCM_BIGDIG *digits;
- SCM ans;
- int n_digits;
-
- {
- long tn;
- tn = (long) n;
- if ((long long)tn == n)
- return scm_long2big (tn);
- }
-
- {
- long_long tn;
-
- for (tn = n, n_digits = 0;
- tn;
- ++n_digits, tn = SCM_BIGDN ((ulong_long)tn))
- ;
- }
-
- i = 0;
- ans = scm_mkbig(n_digits, n<0);
- digits = SCM_BDIGITS(ans);
- if (n < 0)
- n = -n;
- while (i < n_digits) {
- digits[i++] = SCM_BIGLO(n);
- n = SCM_BIGDN((ulong_long)n);
- }
- return ans;
-}
-#endif
-
-
-SCM
-scm_2ulong2big(np)
- unsigned long * np;
-{
- unsigned long n;
- scm_sizet i;
- SCM_BIGDIG *digits;
- SCM ans;
-
- ans = scm_mkbig(2 * SCM_DIGSPERLONG, 0);
- digits = SCM_BDIGITS(ans);
-
- n = np[0];
- for (i = 0; i < SCM_DIGSPERLONG; ++i)
- {
- digits[i] = SCM_BIGLO(n);
- n = SCM_BIGDN((unsigned long)n);
- }
- n = np[1];
- for (i = 0; i < SCM_DIGSPERLONG; ++i)
- {
- digits[i + SCM_DIGSPERLONG] = SCM_BIGLO(n);
- n = SCM_BIGDN((unsigned long)n);
- }
- return ans;
-}
-
-
-
-SCM
-scm_ulong2big(n)
- unsigned long n;
-{
- scm_sizet i = 0;
- SCM_BIGDIG *digits;
- SCM ans = scm_mkbig(SCM_DIGSPERLONG, 0);
- digits = SCM_BDIGITS(ans);
- while (i < SCM_DIGSPERLONG) {
- digits[i++] = SCM_BIGLO(n);
- n = SCM_BIGDN(n);
- }
- return ans;
-}
-
-
-
-int
-scm_bigcomp(x, y)
- SCM x;
- SCM y;
-{
- int xsign = SCM_BIGSIGN(x);
- int ysign = SCM_BIGSIGN(y);
- scm_sizet xlen, ylen;
- if (ysign < xsign) return 1;
- if (ysign > xsign) return -1;
- if ((ylen = SCM_NUMDIGS(y)) > (xlen = SCM_NUMDIGS(x))) return (xsign) ? -1 : 1;
- if (ylen < xlen) return (xsign) ? 1 : -1;
- while(xlen-- && (SCM_BDIGITS(y)[xlen]==SCM_BDIGITS(x)[xlen]));
- if (-1==xlen) return 0;
- return (SCM_BDIGITS(y)[xlen] > SCM_BDIGITS(x)[xlen]) ?
- (xsign ? -1 : 1) : (xsign ? 1 : -1);
-}
-
-#ifndef SCM_DIGSTOOBIG
-
-
-long
-scm_pseudolong(x)
- long x;
-{
- union {
- long l;
- SCM_BIGDIG bd[SCM_DIGSPERLONG];
- } p;
- scm_sizet i = 0;
- if (x < 0) x = -x;
- while (i < SCM_DIGSPERLONG) {p.bd[i++] = SCM_BIGLO(x); x = SCM_BIGDN(x);}
- /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
- return p.l;
-}
-
-#else
-
-
-void
-scm_longdigs(x, digs)
- long x;
- SCM_BIGDIG digs[];
-{
- scm_sizet i = 0;
- if (x < 0) x = -x;
- while (i < SCM_DIGSPERLONG) {digs[i++] = SCM_BIGLO(x); x = SCM_BIGDN(x);}
-}
-#endif
-
-
-
-SCM
-scm_addbig(x, nx, xsgn, bigy, sgny)
- SCM_BIGDIG *x;
- scm_sizet nx;
- int xsgn;
- SCM bigy;
- int sgny;
-{
- /* Assumes nx <= SCM_NUMDIGS(bigy) */
- /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */
- long num = 0;
- scm_sizet i = 0, ny = SCM_NUMDIGS(bigy);
- SCM z = scm_copybig(bigy, SCM_BIGSIGN(bigy) ^ sgny);
- SCM_BIGDIG *zds = SCM_BDIGITS(z);
- if (xsgn ^ SCM_BIGSIGN(z)) {
- do {
- num += (long) zds[i] - x[i];
- if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;}
- else {zds[i] = SCM_BIGLO(num); num = 0;}
- } while (++i < nx);
- if (num && nx==ny) {
- num = 1; i = 0;
- SCM_SETCAR (z, SCM_CAR (z) ^ 0x0100);
- do {
- num += (SCM_BIGRAD-1) - zds[i];
- zds[i++] = SCM_BIGLO(num);
- num = SCM_BIGDN(num);
- } while (i < ny);
- }
- else while (i < ny) {
- num += zds[i];
- if (num < 0) {zds[i++] = num + SCM_BIGRAD; num = -1;}
- else {zds[i++] = SCM_BIGLO(num); num = 0;}
- }
- } else {
- do {
- num += (long) zds[i] + x[i];
- zds[i++] = SCM_BIGLO(num);
- num = SCM_BIGDN(num);
- } while (i < nx);
- if (!num) return z;
- while (i < ny) {
- num += zds[i];
- zds[i++] = SCM_BIGLO(num);
- num = SCM_BIGDN(num);
- if (!num) return z;
- }
- if (num) {z = scm_adjbig(z, ny+1); SCM_BDIGITS(z)[ny] = num; return z;}
- }
- return scm_normbig(z);
-}
-
-
-SCM
-scm_mulbig(x, nx, y, ny, sgn)
- SCM_BIGDIG *x;
- scm_sizet nx;
- SCM_BIGDIG *y;
- scm_sizet ny;
- int sgn;
-{
- scm_sizet i = 0, j = nx + ny;
- unsigned long n = 0;
- SCM z = scm_mkbig(j, sgn);
- SCM_BIGDIG *zds = SCM_BDIGITS(z);
- while (j--) zds[j] = 0;
- do {
- j = 0;
- if (x[i]) {
- do {
- n += zds[i + j] + ((unsigned long) x[i] * y[j]);
- zds[i + j++] = SCM_BIGLO(n);
- n = SCM_BIGDN(n);
- } while (j < ny);
- if (n) {zds[i + j] = n; n = 0;}
- }
- } while (++i < nx);
- return scm_normbig(z);
-}
-
-
-unsigned int
-scm_divbigdig(ds, h, div)
- SCM_BIGDIG *ds;
- scm_sizet h;
- SCM_BIGDIG div;
-{
- register unsigned long t2 = 0;
- while(h--) {
- t2 = SCM_BIGUP(t2) + ds[h];
- ds[h] = t2 / div;
- t2 %= div;
- }
- return t2;
-}
-
-
-
-SCM
-scm_divbigint(x, z, sgn, mode)
- SCM x;
- long z;
- int sgn;
- int mode;
-{
- if (z < 0) z = -z;
- if (z < SCM_BIGRAD) {
- register unsigned long t2 = 0;
- register SCM_BIGDIG *ds = SCM_BDIGITS(x);
- scm_sizet nd = SCM_NUMDIGS(x);
- while(nd--) t2 = (SCM_BIGUP(t2) + ds[nd]) % z;
- if (mode && t2) t2 = z - t2;
- return SCM_MAKINUM(sgn ? -t2 : t2);
- }
- {
-#ifndef SCM_DIGSTOOBIG
- unsigned long t2 = scm_pseudolong(z);
- return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&t2,
- SCM_DIGSPERLONG, sgn, mode);
-#else
- SCM_BIGDIG t2[SCM_DIGSPERLONG];
- scm_longdigs(z, t2);
- return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), t2, SCM_DIGSPERLONG, sgn, mode);
-#endif
- }
-}
-
-
-SCM
-scm_divbigbig(x, nx, y, ny, sgn, modes)
- SCM_BIGDIG *x;
- scm_sizet nx;
- SCM_BIGDIG *y;
- scm_sizet ny;
- int sgn;
- int modes;
-{
- /* modes description
- 0 remainder
- 1 scm_modulo
- 2 quotient
- 3 quotient but returns 0 if division is not exact. */
- scm_sizet i = 0, j = 0;
- long num = 0;
- unsigned long t2 = 0;
- SCM z, newy;
- SCM_BIGDIG d = 0, qhat, *zds, *yds;
- /* algorithm requires nx >= ny */
- if (nx < ny)
- switch (modes) {
- case 0: /* remainder -- just return x */
- z = scm_mkbig(nx, sgn); zds = SCM_BDIGITS(z);
- do {zds[i] = x[i];} while (++i < nx);
- return z;
- case 1: /* scm_modulo -- return y-x */
- z = scm_mkbig(ny, sgn); zds = SCM_BDIGITS(z);
- do {
- num += (long) y[i] - x[i];
- if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;}
- else {zds[i] = num; num = 0;}
- } while (++i < nx);
- while (i < ny) {
- num += y[i];
- if (num < 0) {zds[i++] = num + SCM_BIGRAD; num = -1;}
- else {zds[i++] = num; num = 0;}
- }
- goto doadj;
- case 2: return SCM_INUM0; /* quotient is zero */
- case 3: return 0; /* the division is not exact */
- }
-
- z = scm_mkbig(nx==ny ? nx+2 : nx+1, sgn); zds = SCM_BDIGITS(z);
- if (nx==ny) zds[nx+1] = 0;
- while(!y[ny-1]) ny--; /* in case y came in as a psuedolong */
- if (y[ny-1] < (SCM_BIGRAD>>1)) { /* normalize operands */
- d = SCM_BIGRAD/(y[ny-1]+1);
- newy = scm_mkbig(ny, 0); yds = SCM_BDIGITS(newy);
- while(j < ny)
- {t2 += (unsigned long) y[j]*d; yds[j++] = SCM_BIGLO(t2); t2 = SCM_BIGDN(t2);}
- y = yds; j = 0; t2 = 0;
- while(j < nx)
- {t2 += (unsigned long) x[j]*d; zds[j++] = SCM_BIGLO(t2); t2 = SCM_BIGDN(t2);}
- zds[j] = t2;
- }
- else {zds[j = nx] = 0; while (j--) zds[j] = x[j];}
- j = nx==ny ? nx+1 : nx; /* dividend needs more digits than divisor */
- do { /* loop over digits of quotient */
- if (zds[j]==y[ny-1]) qhat = SCM_BIGRAD-1;
- else qhat = (SCM_BIGUP(zds[j]) + zds[j-1])/y[ny-1];
- if (!qhat) continue;
- i = 0; num = 0; t2 = 0;
- do { /* multiply and subtract */
- t2 += (unsigned long) y[i] * qhat;
- num += zds[j - ny + i] - SCM_BIGLO(t2);
- if (num < 0) {zds[j - ny + i] = num + SCM_BIGRAD; num = -1;}
- else {zds[j - ny + i] = num; num = 0;}
- t2 = SCM_BIGDN(t2);
- } while (++i < ny);
- num += zds[j - ny + i] - t2; /* borrow from high digit; don't update */
- while (num) { /* "add back" required */
- i = 0; num = 0; qhat--;
- do {
- num += (long) zds[j - ny + i] + y[i];
- zds[j - ny + i] = SCM_BIGLO(num);
- num = SCM_BIGDN(num);
- } while (++i < ny);
- num--;
- }
- if (modes & 2) zds[j] = qhat;
- } while (--j >= ny);
- switch (modes) {
- case 3: /* check that remainder==0 */
- for(j = ny;j && !zds[j-1];--j) ; if (j) return 0;
- case 2: /* move quotient down in z */
- j = (nx==ny ? nx+2 : nx+1) - ny;
- for (i = 0;i < j;i++) zds[i] = zds[i+ny];
- ny = i;
- break;
- case 1: /* subtract for scm_modulo */
- i = 0; num = 0; j = 0;
- do {num += y[i] - zds[i];
- j = j | zds[i];
- if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;}
- else {zds[i] = num; num = 0;}
- } while (++i < ny);
- if (!j) return SCM_INUM0;
- case 0: /* just normalize remainder */
- if (d) scm_divbigdig(zds, ny, d);
- }
- doadj:
- for(j = ny;j && !zds[j-1];--j) ;
- if (j * SCM_BITSPERDIG <= sizeof(SCM)*SCM_CHAR_BIT)
- if SCM_INUMP(z = scm_big2inum(z, j)) return z;
- return scm_adjbig(z, j);
-}
-#endif
-
-
-
-
-
-/*** NUMBERS -> STRINGS ***/
-#ifdef SCM_FLOATS
-int scm_dblprec;
-static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
- 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
- 5e-11,5e-12,5e-13,5e-14,5e-15,
- 5e-16,5e-17,5e-18,5e-19,5e-20};
-
-
-
-
-static scm_sizet idbl2str SCM_P ((double f, char *a));
-
-static scm_sizet
-idbl2str(f, a)
- double f;
- char *a;
-{
- int efmt, dpt, d, i, wp = scm_dblprec;
- scm_sizet ch = 0;
- int exp = 0;
-
- if (f == 0.0) goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
- if (f < 0.0) {f = -f;a[ch++]='-';}
- else if (f > 0.0) ;
- else goto funny;
- if (IS_INF(f))
- {
- if (ch == 0) a[ch++]='+';
- funny: a[ch++]='#'; a[ch++]='.'; a[ch++]='#'; return ch;
- }
-# ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
- make-uniform-vector, from causing infinite loops. */
- while (f < 1.0) {f *= 10.0; if (exp-- < DBL_MIN_10_EXP) goto funny;}
- while (f > 10.0) {f *= 0.10; if (exp++ > DBL_MAX_10_EXP) goto funny;}
-# else
- while (f < 1.0) {f *= 10.0; exp--;}
- while (f > 10.0) {f /= 10.0; exp++;}
-# endif
- if (f+fx[wp] >= 10.0) {f = 1.0; exp++;}
- zero:
-# ifdef ENGNOT
- dpt = (exp+9999)%3;
- exp -= dpt++;
- efmt = 1;
-# else
- efmt = (exp < -3) || (exp > wp+2);
- if (!efmt)
- if (exp < 0) {
- a[ch++] = '0';
- a[ch++] = '.';
- dpt = exp;
- while (++dpt) a[ch++] = '0';
- } else
- dpt = exp+1;
- else
- dpt = 1;
-# endif
-
- do {
- d = f;
- f -= d;
- a[ch++] = d+'0';
- if (f < fx[wp]) break;
- if (f+fx[wp] >= 1.0) {
- a[ch-1]++;
- break;
- }
- f *= 10.0;
- if (!(--dpt)) a[ch++] = '.';
- } while (wp--);
-
- if (dpt > 0)
-# ifndef ENGNOT
- if ((dpt > 4) && (exp > 6)) {
- d = (a[0]=='-'?2:1);
- for (i = ch++; i > d; i--)
- a[i] = a[i-1];
- a[d] = '.';
- efmt = 1;
- } else
-# endif
- {
- while (--dpt) a[ch++] = '0';
- a[ch++] = '.';
- }
- if (a[ch-1]=='.') a[ch++]='0'; /* trailing zero */
- if (efmt && exp) {
- a[ch++] = 'e';
- if (exp < 0) {
- exp = -exp;
- a[ch++] = '-';
- }
- for (i = 10; i <= exp; i *= 10);
- for (i /= 10; i; i /= 10) {
- a[ch++] = exp/i + '0';
- exp %= i;
- }
- }
- return ch;
-}
-
-
-static scm_sizet iflo2str SCM_P ((SCM flt, char *str));
-
-static scm_sizet
-iflo2str(flt, str)
- SCM flt;
- char *str;
-{
- scm_sizet i;
-# ifdef SCM_SINGLES
- if SCM_SINGP(flt) i = idbl2str(SCM_FLO(flt), str);
- else
-# endif
- i = idbl2str(SCM_REAL(flt), str);
- if SCM_CPLXP(flt) {
- if(0 <= SCM_IMAG(flt)) /* jeh */
- str[i++] = '+'; /* jeh */
- i += idbl2str(SCM_IMAG(flt), &str[i]);
- str[i++] = 'i';
- }
- return i;
-}
-#endif /* SCM_FLOATS */
-
-
-scm_sizet
-scm_iint2str(num, rad, p)
- long num;
- int rad;
- char *p;
-{
- scm_sizet j;
- register int i = 1, d;
- register long n = num;
- if (n < 0) {n = -n; i++;}
- for (n /= rad;n > 0;n /= rad) i++;
- j = i;
- n = num;
- if (n < 0) {n = -n; *p++ = '-'; i--;}
- while (i--) {
- d = n % rad;
- n /= rad;
- p[i] = d + ((d < 10) ? '0' : 'a' - 10);
- }
- return j;
-}
-
-
-#ifdef SCM_BIGDIG
-
-static SCM big2str SCM_P ((SCM b, register unsigned int radix));
-
-static SCM
-big2str(b, radix)
- SCM b;
- register unsigned int radix;
-{
- SCM t = scm_copybig(b, 0); /* sign of temp doesn't matter */
- register SCM_BIGDIG *ds = SCM_BDIGITS(t);
- scm_sizet i = SCM_NUMDIGS(t);
- scm_sizet j = radix==16 ? (SCM_BITSPERDIG*i)/4+2
- : radix >= 10 ? (SCM_BITSPERDIG*i*241L)/800+2
- : (SCM_BITSPERDIG*i)+2;
- scm_sizet k = 0;
- scm_sizet radct = 0;
- scm_sizet ch; /* jeh */
- SCM_BIGDIG radpow = 1, radmod = 0;
- SCM ss = scm_makstr((long)j, 0);
- char *s = SCM_CHARS(ss), c;
- while ((long) radpow * radix < SCM_BIGRAD) {
- radpow *= radix;
- radct++;
- }
- s[0] = scm_tc16_bigneg==SCM_TYP16(b) ? '-' : '+';
- while ((i || radmod) && j) {
- if (k == 0) {
- radmod = (SCM_BIGDIG)scm_divbigdig(ds, i, radpow);
- k = radct;
- if (!ds[i-1]) i--;
- }
- c = radmod % radix; radmod /= radix; k--;
- s[--j] = c < 10 ? c + '0' : c + 'a' - 10;
- }
- ch = s[0] == '-' ? 1 : 0; /* jeh */
- if (ch < j) { /* jeh */
- for(i = j;j < SCM_LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */
- scm_vector_set_length_x(ss, (SCM)SCM_MAKINUM(ch+SCM_LENGTH(ss)-i)); /* jeh */
- }
- return ss;
-}
-#endif
-
-
-SCM_PROC(s_number_to_string, "number->string", 1, 1, 0, scm_number_to_string);
-
-SCM
-scm_number_to_string(x, radix)
- SCM x;
- SCM radix;
-{
- if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L);
- else SCM_ASSERT(SCM_INUMP(radix), radix, SCM_ARG2, s_number_to_string);
-#ifdef SCM_FLOATS
- if SCM_NINUMP(x) {
- char num_buf[SCM_FLOBUFLEN];
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(x), badx);
- if SCM_BIGP(x) return big2str(x, (unsigned int)SCM_INUM(radix));
-# ifndef RECKLESS
- if (!(SCM_INEXP(x)))
- badx: scm_wta(x, (char *)SCM_ARG1, s_number_to_string);
-# endif
-# else
- SCM_ASSERT(SCM_NIMP(x) && SCM_INEXP(x), x, SCM_ARG1, s_number_to_string);
-# endif
- return scm_makfromstr(num_buf, iflo2str(x, num_buf), 0);
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_number_to_string);
- return big2str(x, (unsigned int)SCM_INUM(radix));
- }
-# else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_number_to_string);
-# endif
-#endif
- {
- char num_buf[SCM_INTBUFLEN];
- return scm_makfromstr(num_buf,
- scm_iint2str(SCM_INUM(x), (int)SCM_INUM(radix), num_buf), 0);
- }
-}
-
-
-/* These print routines are stubbed here so that scm_repl.c doesn't need
- SCM_FLOATS or SCM_BIGDIGs conditionals */
-
-int
-scm_floprint(sexp, port, pstate)
- SCM sexp;
- SCM port;
- scm_print_state *pstate;
-{
-#ifdef SCM_FLOATS
- char num_buf[SCM_FLOBUFLEN];
- scm_gen_write (scm_regular_string, num_buf, iflo2str(sexp, num_buf), port);
-#else
- scm_ipruk("float", sexp, port);
-#endif
- return !0;
-}
-
-
-
-int
-scm_bigprint(exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
-#ifdef SCM_BIGDIG
- exp = big2str(exp, (unsigned int)10);
- scm_gen_write (scm_regular_string, SCM_CHARS(exp), (scm_sizet)SCM_LENGTH(exp), port);
-#else
- scm_ipruk("bignum", exp, port);
-#endif
- return !0;
-}
-/*** END nums->strs ***/
-
-/*** STRINGS -> NUMBERS ***/
-
-static SCM scm_small_istr2int SCM_P ((char *str, long len, long radix));
-
-static SCM
-scm_small_istr2int(str, len, radix)
- char *str;
- long len;
- long radix;
-{
- register long n = 0, ln;
- register int c;
- register int i = 0;
- int lead_neg = 0;
- if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
- switch (*str) { /* leading sign */
- case '-': lead_neg = 1;
- case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
- }
-
- do {
- switch (c = str[i++]) {
- case DIGITS:
- c = c - '0';
- goto accumulate;
- case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
- c = c-'A'+10;
- goto accumulate;
- case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
- c = c-'a'+10;
- accumulate:
- if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
- ln = n;
- n = n * radix - c;
- /* Negation is a workaround for HP700 cc bug */
- if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM)) goto ovfl;
- break;
- default:
- return SCM_BOOL_F; /* not a digit */
- }
- } while (i < len);
- if (!lead_neg) if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM) goto ovfl;
- return SCM_MAKINUM(n);
- ovfl: /* overflow scheme integer */
- return SCM_BOOL_F;
-}
-
-
-
-SCM
-scm_istr2int(str, len, radix)
- char *str;
- long len;
- long radix;
-{
- scm_sizet j;
- register scm_sizet k, blen = 1;
- scm_sizet i = 0;
- int c;
- SCM res;
- register SCM_BIGDIG *ds;
- register unsigned long t2;
-
- if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
-
- /* Short numbers we parse directly into an int, to avoid the overhead
- of creating a bignum. */
- if (len < 6)
- return scm_small_istr2int (str, len, radix);
-
- if (16==radix) j = 1+(4*len*sizeof(char))/(SCM_BITSPERDIG);
- else if (10 <= radix)
- j = 1+(84*len*sizeof(char))/(SCM_BITSPERDIG*25);
- else j = 1+(len*sizeof(char))/(SCM_BITSPERDIG);
- switch (str[0]) { /* leading sign */
- case '-':
- case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
- }
- res = scm_mkbig(j, '-'==str[0]);
- ds = SCM_BDIGITS(res);
- for (k = j;k--;) ds[k] = 0;
- do {
- switch (c = str[i++]) {
- case DIGITS:
- c = c - '0';
- goto accumulate;
- case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
- c = c-'A'+10;
- goto accumulate;
- case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
- c = c-'a'+10;
- accumulate:
- if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
- k = 0;
- t2 = c;
- moretodo:
- while(k < blen) {
- /* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/
- t2 += ds[k]*radix;
- ds[k++] = SCM_BIGLO(t2);
- t2 = SCM_BIGDN(t2);
- }
- if (blen > j)
- scm_num_overflow ("bignum");
- if (t2) {blen++; goto moretodo;}
- break;
- default:
- return SCM_BOOL_F; /* not a digit */
- }
- } while (i < len);
- if (blen * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM))
- if SCM_INUMP(res = scm_big2inum(res, blen)) return res;
- if (j==blen) return res;
- return scm_adjbig(res, blen);
-}
-
-#ifdef SCM_FLOATS
-
-SCM
-scm_istr2flo(str, len, radix)
- char *str;
- long len;
- long radix;
-{
- register int c, i = 0;
- double lead_sgn;
- double res = 0.0, tmp = 0.0;
- int flg = 0;
- int point = 0;
- SCM second;
-
- if (i >= len) return SCM_BOOL_F; /* zero scm_length */
-
- switch (*str) { /* leading sign */
- case '-': lead_sgn = -1.0; i++; break;
- case '+': lead_sgn = 1.0; i++; break;
- default : lead_sgn = 0.0;
- }
- if (i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
-
- if (str[i]=='i' || str[i]=='I') { /* handle `+i' and `-i' */
- if (lead_sgn==0.0) return SCM_BOOL_F; /* must have leading sign */
- if (++i < len) return SCM_BOOL_F; /* `i' not last character */
- return scm_makdbl(0.0, lead_sgn);
- }
- do { /* check initial digits */
- switch (c = str[i]) {
- case DIGITS:
- c = c - '0';
- goto accum1;
- case 'D': case 'E': case 'F':
- if (radix==10) goto out1; /* must be exponent */
- case 'A': case 'B': case 'C':
- c = c-'A'+10;
- goto accum1;
- case 'd': case 'e': case 'f':
- if (radix==10) goto out1;
- case 'a': case 'b': case 'c':
- c = c-'a'+10;
- accum1:
- if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
- res = res * radix + c;
- flg = 1; /* res is valid */
- break;
- default:
- goto out1;
- }
- } while (++i < len);
- out1:
-
- /* if true, then we did see a digit above, and res is valid */
- if (i==len) goto done;
-
- /* By here, must have seen a digit,
- or must have next char be a `.' with radix==10 */
- if (!flg)
- if (!(str[i]=='.' && radix==10))
- return SCM_BOOL_F;
-
- while (str[i]=='#') { /* optional sharps */
- res *= radix;
- if (++i==len) goto done;
- }
-
- if (str[i]=='/') {
- while (++i < len) {
- switch (c = str[i]) {
- case DIGITS:
- c = c - '0';
- goto accum2;
- case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
- c = c-'A'+10;
- goto accum2;
- case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
- c = c-'a'+10;
- accum2:
- if (c >= radix) return SCM_BOOL_F;
- tmp = tmp * radix + c;
- break;
- default:
- goto out2;
- }
- }
- out2:
- if (tmp==0.0) return SCM_BOOL_F; /* `slash zero' not allowed */
- if (i < len)
- while (str[i]=='#') { /* optional sharps */
- tmp *= radix;
- if (++i==len) break;
- }
- res /= tmp;
- goto done;
- }
-
- if (str[i]=='.') { /* decimal point notation */
- if (radix != 10) return SCM_BOOL_F; /* must be radix 10 */
- while (++i < len) {
- switch (c = str[i]) {
- case DIGITS:
- point--;
- res = res*10.0 + c-'0';
- flg = 1;
- break;
- default:
- goto out3;
- }
- }
- out3:
- if (!flg) return SCM_BOOL_F; /* no digits before or after decimal point */
- if (i==len) goto adjust;
- while (str[i]=='#') { /* ignore remaining sharps */
- if (++i==len) goto adjust;
- }
- }
-
- switch (str[i]) { /* exponent */
- case 'd': case 'D':
- case 'e': case 'E':
- case 'f': case 'F':
- case 'l': case 'L':
- case 's': case 'S': {
- int expsgn = 1, expon = 0;
- if (radix != 10) return SCM_BOOL_F; /* only in radix 10 */
- if (++i==len) return SCM_BOOL_F; /* bad exponent */
- switch (str[i]) {
- case '-': expsgn=(-1);
- case '+': if (++i==len) return SCM_BOOL_F; /* bad exponent */
- }
- if (str[i] < '0' || str[i] > '9') return SCM_BOOL_F; /* bad exponent */
- do {
- switch (c = str[i]) {
- case DIGITS:
- expon = expon*10 + c-'0';
- if (expon > MAXEXP) return SCM_BOOL_F; /* exponent too large */
- break;
- default:
- goto out4;
- }
- } while (++i < len);
- out4:
- point += expsgn*expon;
- }
- }
-
- adjust:
- if (point >= 0)
- while (point--) res *= 10.0;
- else
-# ifdef _UNICOS
- while (point++) res *= 0.1;
-# else
- while (point++) res /= 10.0;
-# endif
-
- done:
- /* at this point, we have a legitimate floating point result */
- if (lead_sgn==-1.0) res = -res;
- if (i==len) return scm_makdbl(res, 0.0);
-
- if (str[i]=='i' || str[i]=='I') { /* pure imaginary number */
- if (lead_sgn==0.0) return SCM_BOOL_F; /* must have leading sign */
- if (++i < len) return SCM_BOOL_F; /* `i' not last character */
- return scm_makdbl(0.0, res);
- }
-
- switch (str[i++]) {
- case '-': lead_sgn = -1.0; break;
- case '+': lead_sgn = 1.0; break;
- case '@': { /* polar input for complex number */
- /* get a `real' for scm_angle */
- second = scm_istr2flo(&str[i], (long)(len-i), radix);
- if (!(SCM_INEXP(second))) return SCM_BOOL_F; /* not `real' */
- if (SCM_CPLXP(second)) return SCM_BOOL_F; /* not `real' */
- tmp = SCM_REALPART(second);
- return scm_makdbl(res*cos(tmp), res*sin(tmp));
- }
- default: return SCM_BOOL_F;
- }
-
- /* at this point, last char must be `i' */
- if (str[len-1] != 'i' && str[len-1] != 'I') return SCM_BOOL_F;
- /* handles `x+i' and `x-i' */
- if (i==(len-1)) return scm_makdbl(res, lead_sgn);
- /* get a `ureal' for complex part */
- second = scm_istr2flo(&str[i], (long)((len-i)-1), radix);
- if (!(SCM_INEXP(second))) return SCM_BOOL_F; /* not `ureal' */
- if (SCM_CPLXP(second)) return SCM_BOOL_F; /* not `ureal' */
- tmp = SCM_REALPART(second);
- if (tmp < 0.0) return SCM_BOOL_F; /* not `ureal' */
- return scm_makdbl(res, (lead_sgn*tmp));
-}
-#endif /* SCM_FLOATS */
-
-
-
-SCM
-scm_istring2number(str, len, radix)
- char *str;
- long len;
- long radix;
-{
- int i = 0;
- char ex = 0;
- char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */
- SCM res;
- if (len==1)
- if (*str=='+' || *str=='-') /* Catches lone `+' and `-' for speed */
- return SCM_BOOL_F;
-
- while ((len-i) >= 2 && str[i]=='#' && ++i)
- switch (str[i++]) {
- case 'b': case 'B': if (rx_p++) return SCM_BOOL_F; radix = 2; break;
- case 'o': case 'O': if (rx_p++) return SCM_BOOL_F; radix = 8; break;
- case 'd': case 'D': if (rx_p++) return SCM_BOOL_F; radix = 10; break;
- case 'x': case 'X': if (rx_p++) return SCM_BOOL_F; radix = 16; break;
- case 'i': case 'I': if (ex_p++) return SCM_BOOL_F; ex = 2; break;
- case 'e': case 'E': if (ex_p++) return SCM_BOOL_F; ex = 1; break;
- default: return SCM_BOOL_F;
- }
-
- switch (ex) {
- case 1:
- return scm_istr2int(&str[i], len-i, radix);
- case 0:
- res = scm_istr2int(&str[i], len-i, radix);
- if SCM_NFALSEP(res) return res;
-#ifdef SCM_FLOATS
- case 2: return scm_istr2flo(&str[i], len-i, radix);
-#endif
- }
- return SCM_BOOL_F;
-}
-
-
-SCM_PROC(s_string_to_number, "string->number", 1, 1, 0, scm_string_to_number);
-
-SCM
-scm_string_to_number(str, radix)
- SCM str;
- SCM radix;
-{
- SCM answer;
- if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L);
- else SCM_ASSERT(SCM_INUMP(radix), radix, SCM_ARG2, s_string_to_number);
- SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, s_string_to_number);
- answer = scm_istring2number(SCM_ROCHARS(str), SCM_ROLENGTH(str), SCM_INUM(radix));
- return scm_return_first (answer, str);
-}
-/*** END strs->nums ***/
-
-#ifdef SCM_FLOATS
-
-SCM
-scm_makdbl (x, y)
- double x;
- double y;
-{
- SCM z;
- if ((y==0.0) && (x==0.0)) return scm_flo0;
- SCM_NEWCELL(z);
- SCM_DEFER_INTS;
- if (y==0.0) {
-# ifdef SCM_SINGLES
- float fx = x;
-# ifndef SCM_SINGLESONLY
- if ((-FLTMAX < x) && (x < FLTMAX) && (fx==x))
-# endif
- {
- SCM_SETCAR (z, scm_tc_flo);
- SCM_FLO(z) = x;
- SCM_ALLOW_INTS;
- return z;
- }
-# endif/* def SCM_SINGLES */
- SCM_SETCDR (z, (SCM)scm_must_malloc(1L*sizeof(double), "real"));
- SCM_SETCAR (z, scm_tc_dblr);
- }
- else {
- SCM_SETCDR (z, (SCM)scm_must_malloc(2L*sizeof(double), "complex"));
- SCM_SETCAR (z, scm_tc_dblc);
- SCM_IMAG(z) = y;
- }
- SCM_REAL(z) = x;
- SCM_ALLOW_INTS;
- return z;
-}
-#endif
-
-
-
-SCM
-scm_bigequal(x, y)
- SCM x;
- SCM y;
-{
-#ifdef SCM_BIGDIG
- if (0==scm_bigcomp(x, y)) return SCM_BOOL_T;
-#endif
- return SCM_BOOL_F;
-}
-
-
-
-SCM
-scm_floequal(x, y)
- SCM x;
- SCM y;
-{
-#ifdef SCM_FLOATS
- if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F;
- if (!(SCM_CPLXP(x) && (SCM_IMAG(x) != SCM_IMAG(y)))) return SCM_BOOL_T;
-#endif
- return SCM_BOOL_F;
-}
-
-
-
-
-SCM_PROC(s_number_p, "number?", 1, 0, 0, scm_number_p);
-SCM_PROC(s_complex_p, "complex?", 1, 0, 0, scm_number_p);
-
-SCM
-scm_number_p(x)
- SCM x;
-{
- if SCM_INUMP(x) return SCM_BOOL_T;
-#ifdef SCM_FLOATS
- if (SCM_NIMP(x) && SCM_NUMP(x)) return SCM_BOOL_T;
-#else
-# ifdef SCM_BIGDIG
- if (SCM_NIMP(x) && SCM_NUMP(x)) return SCM_BOOL_T;
-# endif
-#endif
- return SCM_BOOL_F;
-}
-
-
-
-#ifdef SCM_FLOATS
-SCM_PROC(s_real_p, "real?", 1, 0, 0, scm_real_p);
-SCM_PROC(s_rational_p, "rational?", 1, 0, 0, scm_real_p);
-
-SCM
-scm_real_p(x)
- SCM x;
-{
- if (SCM_INUMP(x))
- return SCM_BOOL_T;
- if (SCM_IMP(x))
- return SCM_BOOL_F;
- if (SCM_REALP(x))
- return SCM_BOOL_T;
-# ifdef SCM_BIGDIG
- if (SCM_BIGP(x))
- return SCM_BOOL_T;
-# endif
- return SCM_BOOL_F;
-}
-
-
-
-SCM_PROC(s_int_p, "integer?", 1, 0, 0, scm_integer_p);
-
-SCM
-scm_integer_p(x)
- SCM x;
-{
- double r;
- if SCM_INUMP(x) return SCM_BOOL_T;
- if SCM_IMP(x) return SCM_BOOL_F;
-# ifdef SCM_BIGDIG
- if SCM_BIGP(x) return SCM_BOOL_T;
-# endif
- if (!SCM_INEXP(x)) return SCM_BOOL_F;
- if (SCM_CPLXP(x)) return SCM_BOOL_F;
- r = SCM_REALPART(x);
- if (r==floor(r)) return SCM_BOOL_T;
- return SCM_BOOL_F;
-}
-
-
-
-#endif /* SCM_FLOATS */
-
-SCM_PROC(s_inexact_p, "inexact?", 1, 0, 0, scm_inexact_p);
-
-SCM
-scm_inexact_p(x)
- SCM x;
-{
-#ifdef SCM_FLOATS
- if (SCM_NIMP(x) && SCM_INEXP(x)) return SCM_BOOL_T;
-#endif
- return SCM_BOOL_F;
-}
-
-
-
-
-SCM_PROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p);
-
-SCM
-scm_num_eq_p (x, y)
- SCM x;
- SCM y;
-{
-#ifdef SCM_FLOATS
- SCM t;
- if SCM_NINUMP(x) {
-# ifdef SCM_BIGDIG
-# ifndef RECKLESS
- if (!(SCM_NIMP(x)))
- badx: scm_wta(x, (char *)SCM_ARG1, s_eq_p);
-# endif
- if SCM_BIGP(x) {
- if SCM_INUMP(y) return SCM_BOOL_F;
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
- SCM_ASRTGO(SCM_INEXP(y), bady);
- bigreal:
- return (SCM_REALP(y) && (scm_big2dbl(x)==SCM_REALPART(y))) ? SCM_BOOL_T : SCM_BOOL_F;
- }
- SCM_ASRTGO(SCM_INEXP(x), badx);
-# else
- SCM_ASSERT(SCM_NIMP(x) && SCM_INEXP(x), x, SCM_ARG1, s_eq_p);
-# endif
- if SCM_INUMP(y) {t = x; x = y; y = t; goto realint;}
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;}
- SCM_ASRTGO(SCM_INEXP(y), bady);
-# else
- SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
-# endif
- if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F;
- if SCM_CPLXP(x)
- return (SCM_CPLXP(y) && (SCM_IMAG(x)==SCM_IMAG(y))) ? SCM_BOOL_T : SCM_BOOL_F;
- return SCM_CPLXP(y) ? SCM_BOOL_F : SCM_BOOL_T;
- }
- if SCM_NINUMP(y) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return SCM_BOOL_F;
-# ifndef RECKLESS
- if (!(SCM_INEXP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p);
-# endif
-# else
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_INEXP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p);
-# endif
-# endif
- realint:
- return (SCM_REALP(y) && (((double)SCM_INUM(x))==SCM_REALPART(y))) ? SCM_BOOL_T : SCM_BOOL_F;
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_eq_p);
- if SCM_INUMP(y) return SCM_BOOL_F;
- SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
- return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
- }
- if SCM_NINUMP(y) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_BIGP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p);
-# endif
- return SCM_BOOL_F;
- }
-# else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_eq_p);
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_eq_p);
-# endif
-#endif
- return ((long)x==(long)y) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-
-SCM_PROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p);
-
-SCM
-scm_less_p(x, y)
- SCM x;
- SCM y;
-{
-#ifdef SCM_FLOATS
- if SCM_NINUMP(x) {
-# ifdef SCM_BIGDIG
-# ifndef RECKLESS
- if (!(SCM_NIMP(x)))
- badx: scm_wta(x, (char *)SCM_ARG1, s_less_p);
-# endif
- if SCM_BIGP(x) {
- if SCM_INUMP(y) return SCM_BIGSIGN(x) ? SCM_BOOL_T : SCM_BOOL_F;
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return (1==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
- SCM_ASRTGO(SCM_REALP(y), bady);
- return (scm_big2dbl(x) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F;
- }
- SCM_ASRTGO(SCM_REALP(x), badx);
-# else
- SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_less_p);
-# endif
- if (SCM_INUMP(y))
- return (SCM_REALPART(x) < ((double)SCM_INUM(y))) ? SCM_BOOL_T : SCM_BOOL_F;
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return (SCM_REALPART(x) < scm_big2dbl(y)) ? SCM_BOOL_T : SCM_BOOL_F;
- SCM_ASRTGO(SCM_REALP(y), bady);
-# else
- SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady);
-# endif
- return (SCM_REALPART(x) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F;
- }
- if SCM_NINUMP(y) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return SCM_BIGSIGN(y) ? SCM_BOOL_F : SCM_BOOL_T;
-# ifndef RECKLESS
- if (!(SCM_REALP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_less_p);
-# endif
-# else
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_REALP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_less_p);
-# endif
-# endif
- return (((double)SCM_INUM(x)) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F;
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_less_p);
- if SCM_INUMP(y) return SCM_BIGSIGN(x) ? SCM_BOOL_T : SCM_BOOL_F;
- SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
- return (1==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
- }
- if SCM_NINUMP(y) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_BIGP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_less_p);
-# endif
- return SCM_BIGSIGN(y) ? SCM_BOOL_F : SCM_BOOL_T;
- }
-# else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_less_p);
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_less_p);
-# endif
-#endif
- return ((long)x < (long)y) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-SCM_PROC1 (s_gr_p, ">", scm_tc7_rpsubr, scm_gr_p);
-
-SCM
-scm_gr_p(x, y)
- SCM x;
- SCM y;
-{
- return scm_less_p(y, x);
-}
-
-
-
-SCM_PROC1 (s_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p);
-
-SCM
-scm_leq_p(x, y)
- SCM x;
- SCM y;
-{
- return SCM_BOOL_NOT(scm_less_p(y, x));
-}
-
-
-
-SCM_PROC1 (s_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p);
-
-SCM
-scm_geq_p(x, y)
- SCM x;
- SCM y;
-{
- return SCM_BOOL_NOT(scm_less_p(x, y));
-}
-
-
-
-SCM_PROC(s_zero_p, "zero?", 1, 0, 0, scm_zero_p);
-
-SCM
-scm_zero_p(z)
- SCM z;
-{
-#ifdef SCM_FLOATS
- if SCM_NINUMP(z) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(z), badz);
- if SCM_BIGP(z) return SCM_BOOL_F;
-# ifndef RECKLESS
- if (!(SCM_INEXP(z)))
- badz: scm_wta(z, (char *)SCM_ARG1, s_zero_p);
-# endif
-# else
- SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_zero_p);
-# endif
- return (z==scm_flo0) ? SCM_BOOL_T : SCM_BOOL_F;
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(z) {
- SCM_ASSERT(SCM_NIMP(z) && SCM_BIGP(z), z, SCM_ARG1, s_zero_p);
- return SCM_BOOL_F;
- }
-# else
- SCM_ASSERT(SCM_INUMP(z), z, SCM_ARG1, s_zero_p);
-# endif
-#endif
- return (z==SCM_INUM0) ? SCM_BOOL_T: SCM_BOOL_F;
-}
-
-
-
-SCM_PROC(s_positive_p, "positive?", 1, 0, 0, scm_positive_p);
-
-SCM
-scm_positive_p(x)
- SCM x;
-{
-#ifdef SCM_FLOATS
- if SCM_NINUMP(x) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(x), badx);
- if SCM_BIGP(x) return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F;
-# ifndef RECKLESS
- if (!(SCM_REALP(x)))
- badx: scm_wta(x, (char *)SCM_ARG1, s_positive_p);
-# endif
-# else
- SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_positive_p);
-# endif
- return (SCM_REALPART(x) > 0.0) ? SCM_BOOL_T : SCM_BOOL_F;
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_positive_p);
- return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F;
- }
-# else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_positive_p);
-# endif
-#endif
- return (x > SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-
-SCM_PROC(s_negative_p, "negative?", 1, 0, 0, scm_negative_p);
-
-SCM
-scm_negative_p(x)
- SCM x;
-{
-#ifdef SCM_FLOATS
- if SCM_NINUMP(x) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(x), badx);
- if SCM_BIGP(x) return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_F : SCM_BOOL_T;
-# ifndef RECKLESS
- if (!(SCM_REALP(x)))
- badx: scm_wta(x, (char *)SCM_ARG1, s_negative_p);
-# endif
-# else
- SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_negative_p);
-# endif
- return (SCM_REALPART(x) < 0.0) ? SCM_BOOL_T : SCM_BOOL_F;
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_negative_p);
- return (SCM_TYP16(x)==scm_tc16_bigneg) ? SCM_BOOL_T : SCM_BOOL_F;
- }
-# else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_negative_p);
-# endif
-#endif
- return (x < SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-SCM_PROC1 (s_max, "max", scm_tc7_asubr, scm_max);
-
-SCM
-scm_max(x, y)
- SCM x;
- SCM y;
-{
-#ifdef SCM_FLOATS
- double z;
-#endif
- if SCM_UNBNDP(y) {
-#ifndef RECKLESS
- if (!(SCM_NUMBERP(x)))
- badx: scm_wta(x, (char *)SCM_ARG1, s_max);
-#endif
- return x;
- }
-#ifdef SCM_FLOATS
- if SCM_NINUMP(x) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(x), badx);
- if SCM_BIGP(x) {
- if SCM_INUMP(y) return SCM_BIGSIGN(x) ? y : x;
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return (1==scm_bigcomp(x, y)) ? y : x;
- SCM_ASRTGO(SCM_REALP(y), bady);
- z = scm_big2dbl(x);
- return (z < SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
- }
- SCM_ASRTGO(SCM_REALP(x), badx);
-# else
- SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_max);
-# endif
- if (SCM_INUMP(y))
- return (SCM_REALPART(x) < (z = SCM_INUM(y))) ? scm_makdbl(z, 0.0) : x;
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if (SCM_BIGP(y))
- return (SCM_REALPART(x) < (z = scm_big2dbl(y))) ? scm_makdbl(z, 0.0) : x;
- SCM_ASRTGO(SCM_REALP(y), bady);
-# else
- SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady);
-# endif
- return (SCM_REALPART(x) < SCM_REALPART(y)) ? y : x;
- }
- if SCM_NINUMP(y) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return SCM_BIGSIGN(y) ? x : y;
-# ifndef RECKLESS
- if (!(SCM_REALP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_max);
-# endif
-# else
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_REALP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_max);
-# endif
-# endif
- return ((z = SCM_INUM(x)) < SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_max);
- if SCM_INUMP(y) return SCM_BIGSIGN(x) ? y : x;
- SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
- return (1==scm_bigcomp(x, y)) ? y : x;
- }
- if SCM_NINUMP(y) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_BIGP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_max);
-# endif
- return SCM_BIGSIGN(y) ? x : y;
- }
-# else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_max);
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_max);
-# endif
-#endif
- return ((long)x < (long)y) ? y : x;
-}
-
-
-
-
-SCM_PROC1 (s_min, "min", scm_tc7_asubr, scm_min);
-
-SCM
-scm_min(x, y)
- SCM x;
- SCM y;
-{
-#ifdef SCM_FLOATS
- double z;
-#endif
- if SCM_UNBNDP(y) {
-#ifndef RECKLESS
- if (!(SCM_NUMBERP(x)))
- badx:scm_wta(x, (char *)SCM_ARG1, s_min);
-#endif
- return x;
- }
-#ifdef SCM_FLOATS
- if SCM_NINUMP(x) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(x), badx);
- if SCM_BIGP(x) {
- if SCM_INUMP(y) return SCM_BIGSIGN(x) ? x : y;
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return (-1==scm_bigcomp(x, y)) ? y : x;
- SCM_ASRTGO(SCM_REALP(y), bady);
- z = scm_big2dbl(x);
- return (z > SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
- }
- SCM_ASRTGO(SCM_REALP(x), badx);
-# else
- SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_min);
-# endif
- if SCM_INUMP(y) return (SCM_REALPART(x) > (z = SCM_INUM(y))) ? scm_makdbl(z, 0.0) : x;
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return (SCM_REALPART(x) > (z = scm_big2dbl(y))) ? scm_makdbl(z, 0.0) : x;
- SCM_ASRTGO(SCM_REALP(y), bady);
-# else
- SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady);
-# endif
- return (SCM_REALPART(x) > SCM_REALPART(y)) ? y : x;
- }
- if SCM_NINUMP(y) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return SCM_BIGSIGN(y) ? y : x;
-# ifndef RECKLESS
- if (!(SCM_REALP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_min);
-# endif
-# else
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_REALP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_min);
-# endif
-# endif
- return ((z = SCM_INUM(x)) > SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_min);
- if SCM_INUMP(y) return SCM_BIGSIGN(x) ? x : y;
- SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
- return (-1==scm_bigcomp(x, y)) ? y : x;
- }
- if SCM_NINUMP(y) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_BIGP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_min);
-# endif
- return SCM_BIGSIGN(y) ? y : x;
- }
-# else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_min);
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_min);
-# endif
-#endif
- return ((long)x > (long)y) ? y : x;
-}
-
-
-
-
-SCM_PROC1 (s_sum, "+", scm_tc7_asubr, scm_sum);
-
-SCM
-scm_sum(x, y)
- SCM x;
- SCM y;
-{
- if SCM_UNBNDP(y) {
- if SCM_UNBNDP(x) return SCM_INUM0;
-#ifndef RECKLESS
- if (!(SCM_NUMBERP(x)))
- badx: scm_wta(x, (char *)SCM_ARG1, s_sum);
-#endif
- return x;
- }
-#ifdef SCM_FLOATS
- if SCM_NINUMP(x) {
- SCM t;
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(x), badx);
- if SCM_BIGP(x) {
- if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;}
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) {
- if (SCM_NUMDIGS(x) > SCM_NUMDIGS(y)) {t = x; x = y; y = t;}
- return scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0);
- }
- SCM_ASRTGO(SCM_INEXP(y), bady);
- bigreal: return scm_makdbl(scm_big2dbl(x)+SCM_REALPART(y), SCM_CPLXP(y)?SCM_IMAG(y):0.0);
- }
- SCM_ASRTGO(SCM_INEXP(x), badx);
-# else
- SCM_ASRTGO(SCM_NIMP(x) && SCM_INEXP(x), badx);
-# endif
- if SCM_INUMP(y) {t = x; x = y; y = t; goto intreal;}
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;}
-# ifndef RECKLESS
- else if (!(SCM_INEXP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_sum);
-# endif
-# else
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_INEXP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_sum);
-# endif
-# endif
- { double i = 0.0;
- if SCM_CPLXP(x) i = SCM_IMAG(x);
- if SCM_CPLXP(y) i += SCM_IMAG(y);
- return scm_makdbl(SCM_REALPART(x)+SCM_REALPART(y), i); }
- }
- if SCM_NINUMP(y) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y)
- intbig: {
-# ifndef SCM_DIGSTOOBIG
- long z = scm_pseudolong(SCM_INUM(x));
- return scm_addbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
-# else
- SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
- scm_longdigs(SCM_INUM(x), zdigs);
- return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
-# endif
- }
- SCM_ASRTGO(SCM_INEXP(y), bady);
-# else
- SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
-# endif
- intreal: return scm_makdbl(SCM_INUM(x)+SCM_REALPART(y), SCM_CPLXP(y)?SCM_IMAG(y):0.0);
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM t;
- SCM_ASRTGO(SCM_NIMP(x) && SCM_BIGP(x), badx);
- if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;}
- SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
- if (SCM_NUMDIGS(x) > SCM_NUMDIGS(y)) {t = x; x = y; y = t;}
- return scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0);
- }
- if SCM_NINUMP(y) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_BIGP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_sum);
-# endif
- intbig: {
-# ifndef SCM_DIGSTOOBIG
- long z = scm_pseudolong(SCM_INUM(x));
- return scm_addbig(&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
-# else
- SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
- scm_longdigs(SCM_INUM(x), zdigs);
- return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
-# endif
- }
- }
-# else
- SCM_ASRTGO(SCM_INUMP(x), badx);
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_sum);
-# endif
-#endif
- x = SCM_INUM(x)+SCM_INUM(y);
- if SCM_FIXABLE(x) return SCM_MAKINUM(x);
-#ifdef SCM_BIGDIG
- return scm_long2big(x);
-#else
-# ifdef SCM_FLOATS
- return scm_makdbl((double)x, 0.0);
-# else
- scm_num_overflow (s_sum);
- return SCM_UNSPECIFIED;
-# endif
-#endif
-}
-
-
-
-
-SCM_PROC1 (s_difference, "-", scm_tc7_asubr, scm_difference);
-
-SCM
-scm_difference(x, y)
- SCM x;
- SCM y;
-{
-#ifdef SCM_FLOATS
- if SCM_NINUMP(x) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(x)))
- badx: scm_wta(x, (char *)SCM_ARG1, s_difference);
-# endif
- if SCM_UNBNDP(y) {
-# ifdef SCM_BIGDIG
- if SCM_BIGP(x) {
- x = scm_copybig(x, !SCM_BIGSIGN(x));
- return SCM_NUMDIGS(x) * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM) ?
- scm_big2inum(x, SCM_NUMDIGS(x)) : x;
- }
-# endif
- SCM_ASRTGO(SCM_INEXP(x), badx);
- return scm_makdbl(-SCM_REALPART(x), SCM_CPLXP(x)?-SCM_IMAG(x):0.0);
- }
- if SCM_INUMP(y) return scm_sum(x, SCM_MAKINUM(-SCM_INUM(y)));
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(x) {
- if SCM_BIGP(y) return (SCM_NUMDIGS(x) < SCM_NUMDIGS(y)) ?
- scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0x0100) :
- scm_addbig(SCM_BDIGITS(y), SCM_NUMDIGS(y), SCM_BIGSIGN(y) ^ 0x0100, x, 0);
- SCM_ASRTGO(SCM_INEXP(y), bady);
- return scm_makdbl(scm_big2dbl(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0);
- }
- SCM_ASRTGO(SCM_INEXP(x), badx);
- if SCM_BIGP(y) return scm_makdbl(SCM_REALPART(x)-scm_big2dbl(y), SCM_CPLXP(x)?SCM_IMAG(x):0.0);
- SCM_ASRTGO(SCM_INEXP(y), bady);
-# else
- SCM_ASRTGO(SCM_INEXP(x), badx);
- SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
-# endif
- if SCM_CPLXP(x)
- if SCM_CPLXP(y)
- return scm_makdbl(SCM_REAL(x)-SCM_REAL(y), SCM_IMAG(x)-SCM_IMAG(y));
- else
- return scm_makdbl(SCM_REAL(x)-SCM_REALPART(y), SCM_IMAG(x));
- return scm_makdbl(SCM_REALPART(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0);
- }
- if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;}
- if SCM_NINUMP(y) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) {
-# ifndef SCM_DIGSTOOBIG
- long z = scm_pseudolong(SCM_INUM(x));
- return scm_addbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
-# else
- SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
- scm_longdigs(SCM_INUM(x), zdigs);
- return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
-# endif
- }
-# ifndef RECKLESS
- if (!(SCM_INEXP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_difference);
-# endif
-# else
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_INEXP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_difference);
-# endif
-# endif
- return scm_makdbl(SCM_INUM(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0);
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_difference);
- if SCM_UNBNDP(y) {
- x = scm_copybig(x, !SCM_BIGSIGN(x));
- return SCM_NUMDIGS(x) * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM) ?
- scm_big2inum(x, SCM_NUMDIGS(x)) : x;
- }
- if SCM_INUMP(y) {
-# ifndef SCM_DIGSTOOBIG
- long z = scm_pseudolong(SCM_INUM(y));
- return scm_addbig(&z, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
-# else
- SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
- scm_longdigs(SCM_INUM(x), zdigs);
- return scm_addbig(zdigs, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
-# endif
- }
- SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
- return (SCM_NUMDIGS(x) < SCM_NUMDIGS(y)) ?
- scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0x0100) :
- scm_addbig(SCM_BDIGITS(y), SCM_NUMDIGS(y), SCM_BIGSIGN(y) ^ 0x0100, x, 0);
- }
- if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;}
- if SCM_NINUMP(y) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_BIGP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_difference);
-# endif
- {
-# ifndef SCM_DIGSTOOBIG
- long z = scm_pseudolong(SCM_INUM(x));
- return scm_addbig(&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
-# else
- SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
- scm_longdigs(SCM_INUM(x), zdigs);
- return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
-# endif
- }
- }
-# else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_difference);
- if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;}
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_difference);
-# endif
-#endif
- x = SCM_INUM(x)-SCM_INUM(y);
- checkx:
- if SCM_FIXABLE(x) return SCM_MAKINUM(x);
-#ifdef SCM_BIGDIG
- return scm_long2big(x);
-#else
-# ifdef SCM_FLOATS
- return scm_makdbl((double)x, 0.0);
-# else
- scm_num_overflow (s_difference);
- return SCM_UNSPECIFIED;
-# endif
-#endif
-}
-
-
-
-
-SCM_PROC1 (s_product, "*", scm_tc7_asubr, scm_product);
-
-SCM
-scm_product(x, y)
- SCM x;
- SCM y;
-{
- if SCM_UNBNDP(y) {
- if SCM_UNBNDP(x) return SCM_MAKINUM(1L);
-#ifndef RECKLESS
- if (!(SCM_NUMBERP(x)))
- badx: scm_wta(x, (char *)SCM_ARG1, s_product);
-#endif
- return x;
- }
-#ifdef SCM_FLOATS
- if SCM_NINUMP(x) {
- SCM t;
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(x), badx);
- if SCM_BIGP(x) {
- if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;}
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return scm_mulbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
- SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y));
- SCM_ASRTGO(SCM_INEXP(y), bady);
- bigreal: {
- double bg = scm_big2dbl(x);
- return scm_makdbl(bg*SCM_REALPART(y), SCM_CPLXP(y)?bg*SCM_IMAG(y):0.0); }
- }
- SCM_ASRTGO(SCM_INEXP(x), badx);
-# else
- SCM_ASRTGO(SCM_NIMP(x) && SCM_INEXP(x), badx);
-# endif
- if SCM_INUMP(y) {t = x; x = y; y = t; goto intreal;}
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;}
-# ifndef RECKLESS
- else if (!(SCM_INEXP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_product);
-# endif
-# else
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_INEXP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_product);
-# endif
-# endif
- if SCM_CPLXP(x)
- if SCM_CPLXP(y)
- return scm_makdbl(SCM_REAL(x)*SCM_REAL(y)-SCM_IMAG(x)*SCM_IMAG(y),
- SCM_REAL(x)*SCM_IMAG(y)+SCM_IMAG(x)*SCM_REAL(y));
- else
- return scm_makdbl(SCM_REAL(x)*SCM_REALPART(y), SCM_IMAG(x)*SCM_REALPART(y));
- return scm_makdbl(SCM_REALPART(x)*SCM_REALPART(y),
- SCM_CPLXP(y)?SCM_REALPART(x)*SCM_IMAG(y):0.0);
- }
- if SCM_NINUMP(y) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) {
- intbig: if (SCM_INUM0==x) return x; if (SCM_MAKINUM(1L)==x) return y;
- {
-# ifndef SCM_DIGSTOOBIG
- long z = scm_pseudolong(SCM_INUM(x));
- return scm_mulbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
- SCM_BIGSIGN(y) ? (x>0) : (x<0));
-# else
- SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
- scm_longdigs(SCM_INUM(x), zdigs);
- return scm_mulbig(zdigs, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
- SCM_BIGSIGN(y) ? (x>0) : (x<0));
-# endif
- }
- }
- SCM_ASRTGO(SCM_INEXP(y), bady);
-# else
- SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
-# endif
- intreal: return scm_makdbl(SCM_INUM(x)*SCM_REALPART(y), SCM_CPLXP(y)?SCM_INUM(x)*SCM_IMAG(y):0.0);
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM_ASRTGO(SCM_NIMP(x) && SCM_BIGP(x), badx);
- if SCM_INUMP(y) {SCM t = x; x = y; y = t; goto intbig;}
- SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
- return scm_mulbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
- SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y));
- }
- if SCM_NINUMP(y) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_BIGP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_product);
-# endif
- intbig: if (SCM_INUM0==x) return x; if (SCM_MAKINUM(1L)==x) return y;
- {
-# ifndef SCM_DIGSTOOBIG
- long z = scm_pseudolong(SCM_INUM(x));
- return scm_mulbig(&z, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
- SCM_BIGSIGN(y) ? (x>0) : (x<0));
-# else
- SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
- scm_longdigs(SCM_INUM(x), zdigs);
- return scm_mulbig(zdigs, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
- SCM_BIGSIGN(y) ? (x>0) : (x<0));
-# endif
- }
- }
-# else
- SCM_ASRTGO(SCM_INUMP(x), badx);
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_product);
-# endif
-#endif
- {
- long i, j, k;
- i = SCM_INUM(x);
- if (0==i) return x;
- j = SCM_INUM(y);
- k = i * j;
- y = SCM_MAKINUM(k);
- if (k != SCM_INUM(y) || k/i != j)
-#ifdef SCM_BIGDIG
- { int sgn = (i < 0) ^ (j < 0);
-# ifndef SCM_DIGSTOOBIG
- i = scm_pseudolong(i);
- j = scm_pseudolong(j);
- return scm_mulbig((SCM_BIGDIG *)&i, SCM_DIGSPERLONG,
- (SCM_BIGDIG *)&j, SCM_DIGSPERLONG, sgn);
-# else /* SCM_DIGSTOOBIG */
- SCM_BIGDIG idigs[SCM_DIGSPERLONG];
- SCM_BIGDIG jdigs[SCM_DIGSPERLONG];
- scm_longdigs(i, idigs);
- scm_longdigs(j, jdigs);
- return scm_mulbig(idigs, SCM_DIGSPERLONG, jdigs, SCM_DIGSPERLONG, sgn);
-# endif
- }
-#else
-# ifdef SCM_FLOATS
- return scm_makdbl(((double)i)*((double)j), 0.0);
-# else
- scm_num_overflow (s_product);
-# endif
-#endif
- return y;
- }
-}
-
-
-
-double
-scm_num2dbl (a, why)
- SCM a;
- char * why;
-{
- if (SCM_INUMP (a))
- return (double) SCM_INUM (a);
-#ifdef SCM_FLOATS
- SCM_ASSERT (SCM_NIMP (a), a, "wrong type argument", why);
- if (SCM_REALP (a))
- return (SCM_REALPART (a));
-#endif
-#ifdef SCM_BIGDIG
- return scm_big2dbl (a);
-#endif
- SCM_ASSERT (0, a, "wrong type argument", why);
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC1 (s_divide, "/", scm_tc7_asubr, scm_divide);
-
-SCM
-scm_divide(x, y)
- SCM x;
- SCM y;
-{
-#ifdef SCM_FLOATS
- double d, r, i, a;
- if SCM_NINUMP(x) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(x)))
- badx: scm_wta(x, (char *)SCM_ARG1, s_divide);
-# endif
- if SCM_UNBNDP(y) {
-# ifdef SCM_BIGDIG
- if SCM_BIGP(x) return scm_makdbl(1.0/scm_big2dbl(x), 0.0);
-# endif
- SCM_ASRTGO(SCM_INEXP(x), badx);
- if SCM_REALP(x) return scm_makdbl(1.0/SCM_REALPART(x), 0.0);
- r = SCM_REAL(x); i = SCM_IMAG(x); d = r*r+i*i;
- return scm_makdbl(r/d, -i/d);
- }
-# ifdef SCM_BIGDIG
- if SCM_BIGP(x) {
- SCM z;
- if SCM_INUMP(y) {
- z = SCM_INUM(y);
-#ifndef RECKLESS
- if (!z)
- scm_num_overflow (s_divide);
-#endif
- if (1==z) return x;
- if (z < 0) z = -z;
- if (z < SCM_BIGRAD) {
- SCM w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0));
- return scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z) ?
- scm_makdbl(scm_big2dbl(x)/SCM_INUM(y), 0.0) : scm_normbig(w);
- }
-# ifndef SCM_DIGSTOOBIG
- z = scm_pseudolong(z);
- z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&z, SCM_DIGSPERLONG,
- SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);
-# else
- { SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
- scm_longdigs(z, zdigs);
- z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG,
- SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);}
-# endif
- return z ? z : scm_makdbl(scm_big2dbl(x)/SCM_INUM(y), 0.0);
- }
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) {
- z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
- SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), 3);
- return z ? z : scm_makdbl(scm_big2dbl(x)/scm_big2dbl(y), 0.0);
- }
- SCM_ASRTGO(SCM_INEXP(y), bady);
- if SCM_REALP(y) return scm_makdbl(scm_big2dbl(x)/SCM_REALPART(y), 0.0);
- a = scm_big2dbl(x);
- goto complex_div;
- }
-# endif
- SCM_ASRTGO(SCM_INEXP(x), badx);
- if SCM_INUMP(y) {d = SCM_INUM(y); goto basic_div;}
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) {d = scm_big2dbl(y); goto basic_div;}
- SCM_ASRTGO(SCM_INEXP(y), bady);
-# else
- SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
-# endif
- if SCM_REALP(y) {
- d = SCM_REALPART(y);
- basic_div: return scm_makdbl(SCM_REALPART(x)/d, SCM_CPLXP(x)?SCM_IMAG(x)/d:0.0);
- }
- a = SCM_REALPART(x);
- if SCM_REALP(x) goto complex_div;
- r = SCM_REAL(y); i = SCM_IMAG(y); d = r*r+i*i;
- return scm_makdbl((a*r+SCM_IMAG(x)*i)/d, (SCM_IMAG(x)*r-a*i)/d);
- }
- if SCM_UNBNDP(y) {
- if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x;
- return scm_makdbl(1.0/((double)SCM_INUM(x)), 0.0);
- }
- if SCM_NINUMP(y) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(y), bady);
- if SCM_BIGP(y) return scm_makdbl(SCM_INUM(x)/scm_big2dbl(y), 0.0);
-# ifndef RECKLESS
- if (!(SCM_INEXP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_divide);
-# endif
-# else
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_INEXP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_divide);
-# endif
-# endif
- if (SCM_REALP(y))
- return scm_makdbl(SCM_INUM(x)/SCM_REALPART(y), 0.0);
- a = SCM_INUM(x);
- complex_div:
- r = SCM_REAL(y); i = SCM_IMAG(y); d = r*r+i*i;
- return scm_makdbl((a*r)/d, (-a*i)/d);
- }
-#else
-# ifdef SCM_BIGDIG
- if SCM_NINUMP(x) {
- SCM z;
- SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_divide);
- if SCM_UNBNDP(y) goto ov;
- if SCM_INUMP(y) {
- z = SCM_INUM(y);
- if (!z) goto ov;
- if (1==z) return x;
- if (z < 0) z = -z;
- if (z < SCM_BIGRAD) {
- SCM w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0));
- if (scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z)) goto ov;
- return w;
- }
-# ifndef SCM_DIGSTOOBIG
- z = scm_pseudolong(z);
- z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), &z, SCM_DIGSPERLONG,
- SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);
-# else
- { SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
- scm_longdigs(z, zdigs);
- z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG,
- SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);}
-# endif
- } else {
- SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
- z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
- SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), 3);
- }
- if (!z) goto ov;
- return z;
- }
- if SCM_UNBNDP(y) {
- if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x;
- goto ov;
- }
- if SCM_NINUMP(y) {
-# ifndef RECKLESS
- if (!(SCM_NIMP(y) && SCM_BIGP(y)))
- bady: scm_wta(y, (char *)SCM_ARG2, s_divide);
-# endif
- goto ov;
- }
-# else
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_divide);
- if SCM_UNBNDP(y) {
- if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x;
- goto ov;
- }
- SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_divide);
-# endif
-#endif
- {
- long z = SCM_INUM(y);
- if ((0==z) || SCM_INUM(x)%z) goto ov;
- z = SCM_INUM(x)/z;
- if SCM_FIXABLE(z) return SCM_MAKINUM(z);
-#ifdef SCM_BIGDIG
- return scm_long2big(z);
-#endif
-#ifdef SCM_FLOATS
- ov: return scm_makdbl(((double)SCM_INUM(x))/((double)SCM_INUM(y)), 0.0);
-#else
- ov: scm_num_overflow (s_divide);
- return SCM_UNSPECIFIED;
-#endif
- }
-}
-
-
-
-
-#ifdef SCM_FLOATS
-SCM_PROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh);
-
-double
-scm_asinh(x)
- double x;
-{
- return log(x+sqrt(x*x+1));
-}
-
-
-
-
-SCM_PROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh);
-
-double
-scm_acosh(x)
- double x;
-{
- return log(x+sqrt(x*x-1));
-}
-
-
-
-
-SCM_PROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh);
-
-double
-scm_atanh(x)
- double x;
-{
- return 0.5*log((1+x)/(1-x));
-}
-
-
-
-
-SCM_PROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate);
-
-double
-scm_truncate(x)
- double x;
-{
- if (x < 0.0) return -floor(-x);
- return floor(x);
-}
-
-
-
-SCM_PROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round);
-
-double
-scm_round(x)
- double x;
-{
- double plus_half = x + 0.5;
- double result = floor(plus_half);
- /* Adjust so that the scm_round is towards even. */
- return (plus_half == result && plus_half / 2 != floor(plus_half / 2))
- ? result - 1 : result;
-}
-
-
-
-SCM_PROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact);
-
-double
-scm_exact_to_inexact(z)
- double z;
-{
- return z;
-}
-
-
-SCM_PROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor);
-SCM_PROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil);
-SCM_PROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)())sqrt);
-SCM_PROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)())fabs);
-SCM_PROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)())exp);
-SCM_PROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)())log);
-SCM_PROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)())sin);
-SCM_PROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)())cos);
-SCM_PROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)())tan);
-SCM_PROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)())asin);
-SCM_PROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)())acos);
-SCM_PROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)())atan);
-SCM_PROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)())sinh);
-SCM_PROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)())cosh);
-SCM_PROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)())tanh);
-
-struct dpair {double x, y;};
-
-static void scm_two_doubles SCM_P ((SCM z1, SCM z2, char *sstring, struct dpair *xy));
-
-static void
-scm_two_doubles(z1, z2, sstring, xy)
- SCM z1, z2;
- char *sstring;
- struct dpair *xy;
-{
- if SCM_INUMP(z1) xy->x = SCM_INUM(z1);
- else {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(z1), badz1);
- if SCM_BIGP(z1) xy->x = scm_big2dbl(z1);
- else {
-# ifndef RECKLESS
- if (!(SCM_REALP(z1)))
- badz1: scm_wta(z1, (char *)SCM_ARG1, sstring);
-# endif
- xy->x = SCM_REALPART(z1);}
-# else
- {SCM_ASSERT(SCM_NIMP(z1) && SCM_REALP(z1), z1, SCM_ARG1, sstring);
- xy->x = SCM_REALPART(z1);}
-# endif
- }
- if SCM_INUMP(z2) xy->y = SCM_INUM(z2);
- else {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(z2), badz2);
- if SCM_BIGP(z2) xy->y = scm_big2dbl(z2);
- else {
-# ifndef RECKLESS
- if (!(SCM_REALP(z2)))
- badz2: scm_wta(z2, (char *)SCM_ARG2, sstring);
-# endif
- xy->y = SCM_REALPART(z2);}
-# else
- {SCM_ASSERT(SCM_NIMP(z2) && SCM_REALP(z2), z2, SCM_ARG2, sstring);
- xy->y = SCM_REALPART(z2);}
-# endif
- }
-}
-
-
-
-
-SCM_PROC(s_sys_expt, "$expt", 2, 0, 0, scm_sys_expt);
-
-SCM
-scm_sys_expt(z1, z2)
- SCM z1;
- SCM z2;
-{
- struct dpair xy;
- scm_two_doubles(z1, z2, s_sys_expt, &xy);
- return scm_makdbl(pow(xy.x, xy.y), 0.0);
-}
-
-
-
-SCM_PROC(s_sys_atan2, "$atan2", 2, 0, 0, scm_sys_atan2);
-
-SCM
-scm_sys_atan2(z1, z2)
- SCM z1;
- SCM z2;
-{
- struct dpair xy;
- scm_two_doubles(z1, z2, s_sys_atan2, &xy);
- return scm_makdbl(atan2(xy.x, xy.y), 0.0);
-}
-
-
-
-SCM_PROC(s_make_rectangular, "make-rectangular", 2, 0, 0, scm_make_rectangular);
-
-SCM
-scm_make_rectangular(z1, z2)
- SCM z1;
- SCM z2;
-{
- struct dpair xy;
- scm_two_doubles(z1, z2, s_make_rectangular, &xy);
- return scm_makdbl(xy.x, xy.y);
-}
-
-
-
-SCM_PROC(s_make_polar, "make-polar", 2, 0, 0, scm_make_polar);
-
-SCM
-scm_make_polar(z1, z2)
- SCM z1;
- SCM z2;
-{
- struct dpair xy;
- scm_two_doubles(z1, z2, s_make_polar, &xy);
- return scm_makdbl(xy.x*cos(xy.y), xy.x*sin(xy.y));
-}
-
-
-
-
-SCM_PROC(s_real_part, "real-part", 1, 0, 0, scm_real_part);
-
-SCM
-scm_real_part(z)
- SCM z;
-{
- if SCM_NINUMP(z) {
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(z), badz);
- if SCM_BIGP(z) return z;
-# ifndef RECKLESS
- if (!(SCM_INEXP(z)))
- badz: scm_wta(z, (char *)SCM_ARG1, s_real_part);
-# endif
-# else
- SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_real_part);
-# endif
- if SCM_CPLXP(z) return scm_makdbl(SCM_REAL(z), 0.0);
- }
- return z;
-}
-
-
-
-SCM_PROC(s_imag_part, "imag-part", 1, 0, 0, scm_imag_part);
-
-SCM
-scm_imag_part(z)
- SCM z;
-{
- if SCM_INUMP(z) return SCM_INUM0;
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(z), badz);
- if SCM_BIGP(z) return SCM_INUM0;
-# ifndef RECKLESS
- if (!(SCM_INEXP(z)))
- badz: scm_wta(z, (char *)SCM_ARG1, s_imag_part);
-# endif
-# else
- SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_imag_part);
-# endif
- if SCM_CPLXP(z) return scm_makdbl(SCM_IMAG(z), 0.0);
- return scm_flo0;
-}
-
-
-
-SCM_PROC(s_magnitude, "magnitude", 1, 0, 0, scm_magnitude);
-
-SCM
-scm_magnitude(z)
- SCM z;
-{
- if SCM_INUMP(z) return scm_abs(z);
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(z), badz);
- if SCM_BIGP(z) return scm_abs(z);
-# ifndef RECKLESS
- if (!(SCM_INEXP(z)))
- badz: scm_wta(z, (char *)SCM_ARG1, s_magnitude);
-# endif
-# else
- SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_magnitude);
-# endif
- if SCM_CPLXP(z)
- {
- double i = SCM_IMAG(z), r = SCM_REAL(z);
- return scm_makdbl(sqrt(i*i+r*r), 0.0);
- }
- return scm_makdbl(fabs(SCM_REALPART(z)), 0.0);
-}
-
-
-
-
-SCM_PROC(s_angle, "angle", 1, 0, 0, scm_angle);
-
-SCM
-scm_angle(z)
- SCM z;
-{
- double x, y = 0.0;
- if SCM_INUMP(z) {x = (z>=SCM_INUM0) ? 1.0 : -1.0; goto do_angle;}
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(z), badz);
- if SCM_BIGP(z) {x = (SCM_TYP16(z)==scm_tc16_bigpos) ? 1.0 : -1.0; goto do_angle;}
-# ifndef RECKLESS
- if (!(SCM_INEXP(z))) {
- badz: scm_wta(z, (char *)SCM_ARG1, s_angle);}
-# endif
-# else
- SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_angle);
-# endif
- if (SCM_REALP(z))
- {
- x = SCM_REALPART(z);
- goto do_angle;
- }
- x = SCM_REAL(z); y = SCM_IMAG(z);
- do_angle:
- return scm_makdbl(atan2(y, x), 0.0);
-}
-
-
-SCM_PROC(s_inexact_to_exact, "inexact->exact", 1, 0, 0, scm_inexact_to_exact);
-
-SCM
-scm_inexact_to_exact(z)
- SCM z;
-{
- if SCM_INUMP(z) return z;
-# ifdef SCM_BIGDIG
- SCM_ASRTGO(SCM_NIMP(z), badz);
- if SCM_BIGP(z) return z;
-# ifndef RECKLESS
- if (!(SCM_REALP(z)))
- badz: scm_wta(z, (char *)SCM_ARG1, s_inexact_to_exact);
-# endif
-# else
- SCM_ASSERT(SCM_NIMP(z) && SCM_REALP(z), z, SCM_ARG1, s_inexact_to_exact);
-# endif
-# ifdef SCM_BIGDIG
- {
- double u = floor(SCM_REALPART(z)+0.5);
- if ((u <= SCM_MOST_POSITIVE_FIXNUM) && (-u <= -SCM_MOST_NEGATIVE_FIXNUM)) {
- /* Negation is a workaround for HP700 cc bug */
- SCM ans = SCM_MAKINUM((long)u);
- if (SCM_INUM(ans)==(long)u) return ans;
- }
- SCM_ASRTGO(!IS_INF(u), badz); /* problem? */
- return scm_dbl2big(u);
- }
-# else
- return SCM_MAKINUM((long)floor(SCM_REALPART(z)+0.5));
-# endif
-}
-
-
-
-#else /* ~SCM_FLOATS */
-SCM_PROC(s_trunc, "truncate", 1, 0, 0, scm_trunc);
-
-SCM
-scm_trunc(x)
- SCM x;
-{
- SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_truncate);
- return x;
-}
-
-
-
-#endif /* SCM_FLOATS */
-
-#ifdef SCM_BIGDIG
-# ifdef SCM_FLOATS
-/* d must be integer */
-
-SCM
-scm_dbl2big(d)
- double d;
-{
- scm_sizet i = 0;
- long c;
- SCM_BIGDIG *digits;
- SCM ans;
- double u = (d < 0)?-d:d;
- while (0 != floor(u)) {u /= SCM_BIGRAD;i++;}
- ans = scm_mkbig(i, d < 0);
- digits = SCM_BDIGITS(ans);
- while (i--) {
- u *= SCM_BIGRAD;
- c = floor(u);
- u -= c;
- digits[i] = c;
- }
-#ifndef RECKLESS
- if (u != 0)
- scm_num_overflow ("dbl2big");
-#endif
- return ans;
-}
-
-
-
-
-double
-scm_big2dbl(b)
- SCM b;
-{
- double ans = 0.0;
- scm_sizet i = SCM_NUMDIGS(b);
- SCM_BIGDIG *digits = SCM_BDIGITS(b);
- while (i--) ans = digits[i] + SCM_BIGRAD*ans;
- if (scm_tc16_bigneg==SCM_TYP16(b)) return -ans;
- return ans;
-}
-# endif
-#endif
-
-
-SCM
-scm_long2num(sl)
- long sl;
-{
- if (!SCM_FIXABLE(sl)) {
-#ifdef SCM_BIGDIG
- return scm_long2big(sl);
-#else
-# ifdef SCM_FLOATS
- return scm_makdbl((double) sl, 0.0);
-# else
- return SCM_BOOL_F;
-# endif
-#endif
- }
- return SCM_MAKINUM(sl);
-}
-
-
-#ifdef LONGLONGS
-
-SCM
-scm_long_long2num(sl)
- long_long sl;
-{
- if (!SCM_FIXABLE(sl)) {
-#ifdef SCM_BIGDIG
- return scm_long_long2big(sl);
-#else
-# ifdef SCM_FLOATS
- return scm_makdbl((double) sl, 0.0);
-# else
- return SCM_BOOL_F;
-# endif
-#endif
- }
- return SCM_MAKINUM(sl);
-}
-#endif
-
-
-
-SCM
-scm_ulong2num(sl)
- unsigned long sl;
-{
- if (!SCM_POSFIXABLE(sl)) {
-#ifdef SCM_BIGDIG
- return scm_ulong2big(sl);
-#else
-# ifdef SCM_FLOATS
- return scm_makdbl((double) sl, 0.0);
-# else
- return SCM_BOOL_F;
-# endif
-#endif
- }
- return SCM_MAKINUM(sl);
-}
-
-
-long
-scm_num2long(num, pos, s_caller)
- SCM num;
- char *pos;
- char *s_caller;
-{
- long res;
- if (SCM_INUMP(num))
- {
- res = SCM_INUM(num);
- return res;
- }
- SCM_ASRTGO(SCM_NIMP(num), errout);
-#ifdef SCM_FLOATS
- if (SCM_REALP(num))
- {
- double u = SCM_REALPART(num);
- res = u;
- if ((double)res == u)
- {
- return res;
- }
- }
-#endif
-#ifdef SCM_BIGDIG
- if (SCM_BIGP(num)) {
- long oldres;
- scm_sizet l;
- res = 0;
- oldres = 0;
- for(l = SCM_NUMDIGS(num);l--;)
- {
- res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l];
- if (res < oldres)
- goto errout;
- oldres = res;
- }
- if (SCM_TYP16 (num) == scm_tc16_bigpos)
- return res;
- else
- return -res;
- }
-#endif
- errout: scm_wta(num, pos, s_caller);
- return SCM_UNSPECIFIED;
-}
-
-
-
-
-
-long
-num2long(num, pos, s_caller)
- SCM num;
- char *pos;
- char *s_caller;
-{
- long res;
- if SCM_INUMP(num) {
- res = SCM_INUM((long)num);
- return res;
- }
- SCM_ASRTGO(SCM_NIMP(num), errout);
-#ifdef SCM_FLOATS
- if SCM_REALP(num) {
- double u = SCM_REALPART(num);
- if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u)
- && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3))) {
- res = u;
- return res;
- }
- }
-#endif
-#ifdef SCM_BIGDIG
- if SCM_BIGP(num) {
- scm_sizet l = SCM_NUMDIGS(num);
- SCM_ASRTGO(SCM_DIGSPERLONG >= l, errout);
- res = 0;
- for(;l--;) res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l];
- return res;
- }
-#endif
- errout: scm_wta(num, pos, s_caller);
- return SCM_UNSPECIFIED;
-}
-
-
-#ifdef LONGLONGS
-
-long_long
-scm_num2long_long(num, pos, s_caller)
- SCM num;
- char *pos;
- char *s_caller;
-{
- long_long res;
- if SCM_INUMP(num) {
- res = SCM_INUM((long_long)num);
- return res;
- }
- SCM_ASRTGO(SCM_NIMP(num), errout);
-#ifdef SCM_FLOATS
- if SCM_REALP(num) {
- double u = SCM_REALPART(num);
- if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u)
- && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3))) {
- res = u;
- return res;
- }
- }
-#endif
-#ifdef SCM_BIGDIG
- if SCM_BIGP(num) {
- scm_sizet l = SCM_NUMDIGS(num);
- SCM_ASRTGO(SCM_DIGSPERLONGLONG >= l, errout);
- res = 0;
- for(;l--;) res = SCM_LONGLONGBIGUP(res) + SCM_BDIGITS(num)[l];
- return res;
- }
-#endif
- errout: scm_wta(num, pos, s_caller);
- return SCM_UNSPECIFIED;
-}
-#endif
-
-
-
-unsigned long
-scm_num2ulong(num, pos, s_caller)
- SCM num;
- char *pos;
- char *s_caller;
-{
- unsigned long res;
- if (SCM_INUMP(num))
- {
- res = SCM_INUM((unsigned long)num);
- return res;
- }
- SCM_ASRTGO(SCM_NIMP(num), errout);
-#ifdef SCM_FLOATS
- if (SCM_REALP(num))
- {
- double u = SCM_REALPART(num);
- if ((0 <= u) && (u <= (unsigned long)~0L))
- {
- res = u;
- return res;
- }
- }
-#endif
-#ifdef SCM_BIGDIG
- if (SCM_BIGP(num)) {
- unsigned long oldres;
- scm_sizet l;
- res = 0;
- oldres = 0;
- for(l = SCM_NUMDIGS(num);l--;)
- {
- res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l];
- if (res < oldres)
- goto errout;
- oldres = res;
- }
- return res;
- }
-#endif
- errout: scm_wta(num, pos, s_caller);
- return SCM_UNSPECIFIED;
-}
-
-
-#ifdef SCM_FLOATS
-# ifndef DBL_DIG
-static void add1 SCM_P ((double f, double *fsum));
-static void add1(f, fsum)
- double f, *fsum;
-{
- *fsum = f + 1.0;
-}
-# endif
-#endif
-
-
-
-void
-scm_init_numbers ()
-{
-#ifdef SCM_FLOATS
- SCM_NEWCELL(scm_flo0);
-# ifdef SCM_SINGLES
- SCM_SETCAR (scm_flo0, scm_tc_flo);
- SCM_FLO(scm_flo0) = 0.0;
-# else
- SCM_SETCDR (scm_flo0, (SCM)scm_must_malloc(1L*sizeof(double), "real"));
- SCM_REAL(scm_flo0) = 0.0;
- SCM_SETCAR (scm_flo0, scm_tc_dblr);
-# endif
-# ifdef DBL_DIG
- scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
-# else
- { /* determine floating point precision */
- double f = 0.1;
- double fsum = 1.0+f;
- while (fsum != 1.0) {
- f /= 10.0;
- if (++scm_dblprec > 20) break;
- add1(f, &fsum);
- }
- scm_dblprec = scm_dblprec-1;
- }
-# endif /* DBL_DIG */
-#endif
-#include "numbers.x"
-}
-
diff --git a/libguile/numbers.h b/libguile/numbers.h
deleted file mode 100644
index d34e09d9c..000000000
--- a/libguile/numbers.h
+++ /dev/null
@@ -1,323 +0,0 @@
-/* classes: h_files */
-
-#ifndef NUMBERSH
-#define NUMBERSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-
-/* Immediate Numbers
- *
- * Inums are exact integer data that fits within an SCM word.
- *
- * SCM_INUMP applies only to values known to be Scheme objects.
- * In particular, SCM_INUMP (SCM_CAR (x)) is valid only if x is known
- * to be a SCM_CONSP. If x is only known to be a SCM_NIMP,
- * SCM_INUMP (SCM_CAR (x)) can give wrong answers.
- */
-
-#define SCM_INUMP(x) (2 & (int)(x))
-#define SCM_NINUMP(x) (!SCM_INUMP(x))
-
-#ifdef __TURBOC__
-/* shifts of more than one are done by a library call, single shifts are
- * performed in registers
- */
-# define SCM_MAKINUM(x) ((((x)<<1)<<1)+2L)
-#else
-# define SCM_MAKINUM(x) (((x)<<2)+2L)
-#endif /* def __TURBOC__ */
-
-
-/* SCM_SRS is signed right shift */
-/* Turbo C++ v1.0 has a bug with right shifts of signed longs!
- * It is believed to be fixed in Turbo C++ v1.01
- */
-#if (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295)
-# define SCM_SRS(x, y) ((x)>>y)
-# ifdef __TURBOC__
-# define SCM_INUM(x) (((x)>>1)>>1)
-# else
-# define SCM_INUM(x) SCM_SRS(x, 2)
-# endif /* def __TURBOC__ */
-#else
-# define SCM_SRS(x, y) (((x)<0) ? ~((~(x))>>y) : (x)>>y)
-# define SCM_INUM(x) SCM_SRS(x, 2)
-#endif /* (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295) */
-
-
-/* A name for 0.
- */
-#define SCM_INUM0 ((SCM) 2)
-
-
-
-/* SCM_FIXABLE is non-0 if its long argument can be encoded in an SCM_INUM.
- */
-#define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM)
-#define SCM_NEGFIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM)
-#define SCM_UNEGFIXABLE(n) ((n) <= -SCM_MOST_NEGATIVE_FIXNUM)
-#define SCM_FIXABLE(n) (SCM_POSFIXABLE(n) && SCM_NEGFIXABLE(n))
-
-/* SCM_INTBUFLEN is the maximum number of characters neccessary for the
- * printed or scm_string representation of an exact immediate.
- */
-
-#ifndef SCM_CHAR_BIT
-# define SCM_CHAR_BIT 8
-#endif /* ndef SCM_CHAR_BIT */
-#ifndef SCM_LONG_BIT
-# define SCM_LONG_BIT (SCM_CHAR_BIT*sizeof(long)/sizeof(char))
-#endif /* ndef SCM_LONG_BIT */
-#define SCM_INTBUFLEN (5+SCM_LONG_BIT)
-
-/* SCM_FLOBUFLEN is the maximum number of characters neccessary for the
- * printed or scm_string representation of an inexact number.
- */
-
-#define SCM_FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
-
-
-
-
-/* Numbers
- */
-
-#define SCM_INEXP(x) (SCM_TYP16(x)==scm_tc16_flo)
-#define SCM_CPLXP(x) (SCM_CAR(x)==scm_tc_dblc)
-#define SCM_REAL(x) (*(((scm_dbl *) (SCM2PTR(x)))->real))
-#define SCM_IMAG(x) (*((double *)(SCM_CHARS(x)+sizeof(double))))
-/* ((&SCM_REAL(x))[1]) */
-
-
-#ifdef SCM_SINGLES
-#define SCM_REALP(x) ((~SCM_REAL_PART & SCM_CAR(x))==scm_tc_flo)
-#define SCM_SINGP(x) (SCM_CAR(x)==scm_tc_flo)
-#define SCM_FLO(x) (((scm_flo *)(SCM2PTR(x)))->num)
-#define SCM_REALPART(x) (SCM_SINGP(x)?0.0+SCM_FLO(x):SCM_REAL(x))
-#else /* SCM_SINGLES */
-#define SCM_REALP(x) (SCM_CAR(x)==scm_tc_dblr)
-#define SCM_REALPART SCM_REAL
-#endif /* SCM_SINGLES */
-
-
-/* Define SCM_BIGDIG to an integer type whose size is smaller than long if
- * you want bignums. SCM_BIGRAD is one greater than the biggest SCM_BIGDIG.
- *
- * Define SCM_DIGSTOOBIG if the digits equivalent to a long won't fit in a long.
- */
-#ifdef BIGNUMS
-# ifdef _UNICOS
-# define SCM_DIGSTOOBIG
-# if (1L << 31) <= SCM_USHRT_MAX
-# define SCM_BIGDIG unsigned short
-# else
-# define SCM_BIGDIG unsigned int
-# endif /* (1L << 31) <= USHRT_MAX */
-# define SCM_BITSPERDIG 32
-# else
-# define SCM_BIGDIG unsigned short
-# define SCM_BITSPERDIG (sizeof(SCM_BIGDIG)*SCM_CHAR_BIT)
-# endif /* def _UNICOS */
-
-# define SCM_BIGRAD (1L << SCM_BITSPERDIG)
-# define SCM_DIGSPERLONG ((scm_sizet)((sizeof(long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG))
-# define SCM_DIGSPERLONGLONG ((scm_sizet)((sizeof(long long)*SCM_CHAR_BIT+SCM_BITSPERDIG-1)/SCM_BITSPERDIG))
-# define SCM_BIGUP(x) ((unsigned long)(x) << SCM_BITSPERDIG)
-# define SCM_LONGLONGBIGUP(x) ((ulong_long)(x) << SCM_BITSPERDIG)
-# define SCM_BIGDN(x) ((x) >> SCM_BITSPERDIG)
-# define SCM_BIGLO(x) ((x) & (SCM_BIGRAD-1))
-#endif /* def BIGNUMS */
-
-#ifndef SCM_BIGDIG
-/* Definition is not really used but helps various function
- * prototypes to compile with conditionalization.
- */
-# define SCM_BIGDIG unsigned short
-# define SCM_NO_BIGDIG
-# ifndef SCM_FLOATS
-# define SCM_INUMS_ONLY
-# endif /* ndef SCM_FLOATS */
-#endif /* ndef SCM_BIGDIG */
-
-#ifdef SCM_FLOATS
-#define SCM_NUMBERP(x) (SCM_INUMP(x) || (SCM_NIMP(x) && SCM_NUMP(x)))
-#else
-#ifdef SCM_BIGDIG
-#define SCM_NUMBERP(x) (SCM_INUMP(x) || (SCM_NIMP(x) && SCM_NUMP(x)))
-#else
-#define SCM_NUMBERP SCM_INUMP
-#endif
-#endif
-#define SCM_NUMP(x) ((0xfcff & (int)SCM_CAR(x))==scm_tc7_smob)
-#define SCM_BIGP(x) (SCM_TYP16S(x)==scm_tc16_bigpos)
-#define SCM_BIGSIGN(x) (0x0100 & (int)SCM_CAR(x))
-#define SCM_BDIGITS(x) ((SCM_BIGDIG *)(SCM_CDR(x)))
-#define SCM_NUMDIGS(x) ((scm_sizet)(SCM_CAR(x)>>16))
-#define SCM_SETNUMDIGS(x, v, t) SCM_SETCAR(x, (((v)+0L)<<16)+(t))
-
-
-#ifdef SCM_FLOATS
-typedef struct scm_dblproc
-{
- char *scm_string;
- double (*cproc) ();
-} scm_dblproc;
-
-#ifdef SCM_SINGLES
-typedef struct scm_flo
-{
- SCM type;
- float num;
-} scm_flo;
-#endif
-
-typedef struct scm_dbl
-{
- SCM type;
- double *real;
-} scm_dbl;
-#endif
-
-
-
-
-
-extern SCM scm_exact_p SCM_P ((SCM x));
-extern SCM scm_odd_p SCM_P ((SCM n));
-extern SCM scm_even_p SCM_P ((SCM n));
-extern SCM scm_abs SCM_P ((SCM x));
-extern SCM scm_quotient SCM_P ((SCM x, SCM y));
-extern SCM scm_remainder SCM_P ((SCM x, SCM y));
-extern SCM scm_modulo SCM_P ((SCM x, SCM y));
-extern SCM scm_gcd SCM_P ((SCM x, SCM y));
-extern SCM scm_lcm SCM_P ((SCM n1, SCM n2));
-extern SCM scm_logand SCM_P ((SCM n1, SCM n2));
-extern SCM scm_logior SCM_P ((SCM n1, SCM n2));
-extern SCM scm_logxor SCM_P ((SCM n1, SCM n2));
-extern SCM scm_logtest SCM_P ((SCM n1, SCM n2));
-extern SCM scm_logbit_p SCM_P ((SCM n1, SCM n2));
-extern SCM scm_lognot SCM_P ((SCM n));
-extern SCM scm_integer_expt SCM_P ((SCM z1, SCM z2));
-extern SCM scm_ash SCM_P ((SCM n, SCM cnt));
-extern SCM scm_bit_extract SCM_P ((SCM n, SCM start, SCM end));
-extern SCM scm_logcount SCM_P ((SCM n));
-extern SCM scm_integer_length SCM_P ((SCM n));
-extern SCM scm_mkbig SCM_P ((scm_sizet nlen, int sign));
-extern SCM scm_big2inum SCM_P ((SCM b, scm_sizet l));
-extern SCM scm_adjbig SCM_P ((SCM b, scm_sizet nlen));
-extern SCM scm_normbig SCM_P ((SCM b));
-extern SCM scm_copybig SCM_P ((SCM b, int sign));
-extern SCM scm_long2big SCM_P ((long n));
-extern SCM scm_long_long2big SCM_P ((long_long n));
-extern SCM scm_2ulong2big SCM_P ((unsigned long * np));
-extern SCM scm_ulong2big SCM_P ((unsigned long n));
-extern int scm_bigcomp SCM_P ((SCM x, SCM y));
-extern long scm_pseudolong SCM_P ((long x));
-extern void scm_longdigs SCM_P ((long x, SCM_BIGDIG digs[]));
-extern SCM scm_addbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny));
-extern SCM scm_mulbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn));
-extern unsigned int scm_divbigdig SCM_P ((SCM_BIGDIG *ds, scm_sizet h, SCM_BIGDIG div));
-extern SCM scm_divbigint SCM_P ((SCM x, long z, int sgn, int mode));
-extern SCM scm_divbigbig SCM_P ((SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes));
-extern scm_sizet scm_iint2str SCM_P ((long num, int rad, char *p));
-extern SCM scm_number_to_string SCM_P ((SCM x, SCM radix));
-extern int scm_floprint SCM_P ((SCM sexp, SCM port, scm_print_state *pstate));
-extern int scm_bigprint SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-extern SCM scm_istr2int SCM_P ((char *str, long len, long radix));
-extern SCM scm_istr2flo SCM_P ((char *str, long len, long radix));
-extern SCM scm_istring2number SCM_P ((char *str, long len, long radix));
-extern SCM scm_string_to_number SCM_P ((SCM str, SCM radix));
-extern SCM scm_makdbl SCM_P ((double x, double y));
-extern SCM scm_bigequal SCM_P ((SCM x, SCM y));
-extern SCM scm_floequal SCM_P ((SCM x, SCM y));
-extern SCM scm_number_p SCM_P ((SCM x));
-extern SCM scm_real_p SCM_P ((SCM x));
-extern SCM scm_integer_p SCM_P ((SCM x));
-extern SCM scm_inexact_p SCM_P ((SCM x));
-extern SCM scm_num_eq_p SCM_P ((SCM x, SCM y));
-extern SCM scm_less_p SCM_P ((SCM x, SCM y));
-extern SCM scm_gr_p SCM_P ((SCM x, SCM y));
-extern SCM scm_leq_p SCM_P ((SCM x, SCM y));
-extern SCM scm_geq_p SCM_P ((SCM x, SCM y));
-extern SCM scm_zero_p SCM_P ((SCM z));
-extern SCM scm_positive_p SCM_P ((SCM x));
-extern SCM scm_negative_p SCM_P ((SCM x));
-extern SCM scm_max SCM_P ((SCM x, SCM y));
-extern SCM scm_min SCM_P ((SCM x, SCM y));
-extern SCM scm_sum SCM_P ((SCM x, SCM y));
-extern SCM scm_difference SCM_P ((SCM x, SCM y));
-extern SCM scm_product SCM_P ((SCM x, SCM y));
-extern double scm_num2dbl SCM_P ((SCM a, char * why));
-extern SCM scm_divide SCM_P ((SCM x, SCM y));
-extern double scm_asinh SCM_P ((double x));
-extern double scm_acosh SCM_P ((double x));
-extern double scm_atanh SCM_P ((double x));
-extern double scm_truncate SCM_P ((double x));
-extern double scm_round SCM_P ((double x));
-extern double scm_exact_to_inexact SCM_P ((double z));
-extern SCM scm_sys_expt SCM_P ((SCM z1, SCM z2));
-extern SCM scm_sys_atan2 SCM_P ((SCM z1, SCM z2));
-extern SCM scm_make_rectangular SCM_P ((SCM z1, SCM z2));
-extern SCM scm_make_polar SCM_P ((SCM z1, SCM z2));
-extern SCM scm_real_part SCM_P ((SCM z));
-extern SCM scm_imag_part SCM_P ((SCM z));
-extern SCM scm_magnitude SCM_P ((SCM z));
-extern SCM scm_angle SCM_P ((SCM z));
-extern SCM scm_inexact_to_exact SCM_P ((SCM z));
-extern SCM scm_trunc SCM_P ((SCM x));
-extern SCM scm_dbl2big SCM_P ((double d));
-extern double scm_big2dbl SCM_P ((SCM b));
-extern SCM scm_long2num SCM_P ((long sl));
-extern SCM scm_long_long2num SCM_P ((long_long sl));
-extern SCM scm_ulong2num SCM_P ((unsigned long sl));
-extern long scm_num2long SCM_P ((SCM num, char *pos, char *s_caller));
-extern long num2long SCM_P ((SCM num, char *pos, char *s_caller));
-extern long_long scm_num2long_long SCM_P ((SCM num, char *pos, char *s_caller));
-extern unsigned long scm_num2ulong SCM_P ((SCM num, char *pos, char *s_caller));
-extern void scm_init_numbers SCM_P ((void));
-
-#endif /* NUMBERSH */
diff --git a/libguile/objprop.c b/libguile/objprop.c
deleted file mode 100644
index f644a6694..000000000
--- a/libguile/objprop.c
+++ /dev/null
@@ -1,120 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "hashtab.h"
-#include "alist.h"
-#include "weaks.h"
-
-#include "objprop.h"
-
-
-/* {Object Properties}
- */
-
-SCM_PROC(s_object_properties, "object-properties", 1, 0, 0, scm_object_properties);
-
-SCM
-scm_object_properties (obj)
- SCM obj;
-{
- return scm_hashq_ref (scm_object_whash, obj, SCM_EOL);
-}
-
-
-SCM_PROC(s_set_object_properties_x, "set-object-properties!", 2, 0, 0, scm_set_object_properties_x);
-
-SCM
-scm_set_object_properties_x (obj, plist)
- SCM obj;
- SCM plist;
-{
- SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, plist);
- SCM_SETCDR (handle, plist);
- return plist;
-}
-
-SCM_PROC(s_object_property, "object-property", 2, 0, 0, scm_object_property);
-
-SCM
-scm_object_property (obj, key)
- SCM obj;
- SCM key;
-{
- SCM assoc;
- assoc = scm_assq (key, SCM_CDR (scm_object_properties (obj)));
- return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
-}
-
-SCM_PROC(s_set_object_property_x, "set-object-property!", 3, 0, 0, scm_set_object_property_x);
-
-SCM
-scm_set_object_property_x (obj, key, val)
- SCM obj;
- SCM key;
- SCM val;
-{
- SCM h;
- SCM assoc;
- h = scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL);
- SCM_DEFER_INTS;
- assoc = scm_assoc (key, SCM_CDR (h));
- if (SCM_NIMP (assoc))
- SCM_SETCDR (assoc, val);
- else
- {
- assoc = scm_acons (key, val, SCM_CDR (h));
- SCM_SETCDR (h, assoc);
- }
- SCM_ALLOW_INTS;
- return val;
-}
-
-
-void
-scm_init_objprop ()
-{
- scm_object_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (511));
-#include "objprop.x"
-}
-
diff --git a/libguile/objprop.h b/libguile/objprop.h
deleted file mode 100644
index 89a662346..000000000
--- a/libguile/objprop.h
+++ /dev/null
@@ -1,62 +0,0 @@
-/* classes: h_files */
-
-#ifndef OBJPROPH
-#define OBJPROPH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "libguile/__scm.h"
-
-
-
-
-
-
-
-extern SCM scm_object_properties SCM_P ((SCM obj));
-extern SCM scm_set_object_properties_x SCM_P ((SCM obj, SCM plist));
-extern SCM scm_object_property SCM_P ((SCM obj, SCM key));
-extern SCM scm_set_object_property_x SCM_P ((SCM obj, SCM key, SCM val));
-extern void scm_init_objprop SCM_P ((void));
-
-#endif /* OBJPROPH */
diff --git a/libguile/options.c b/libguile/options.c
deleted file mode 100644
index ade12e2ee..000000000
--- a/libguile/options.c
+++ /dev/null
@@ -1,227 +0,0 @@
-/* Copyright (C) 1995,1996 Mikael Djurfeldt
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- *
- * The author can be reached at djurfeldt@nada.kth.se
- * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-
-#include "options.h"
-
-
-/* {Run-time options}
- *
- * This is the basic interface for low-level configuration of the
- * Guile library. It is used for configuring the reader, evaluator,
- * printer and debugger.
- *
- * Motivation:
- *
- * 1. Altering option settings can have side effects.
- * 2. Option values can be stored in native format.
- * (Important for efficiency in, e. g., the evaluator.)
- * 3. Doesn't use up name space.
- * 4. Options can be naturally grouped => ease of use.
- */
-
-/* scm_options is the core of all options interface procedures.
- *
- * Some definitions:
- *
- * Run time options in Guile are arranged in groups. Each group
- * affects a certain aspect of the behaviour of the library.
- *
- * An "options interface procedure" manages one group of options. It
- * can be used to check or set options, or to get documentation for
- * all options of a group. The options interface procedure is not
- * intended to be called directly by the user. The user should
- * instead call
- *
- * (<group>-options)
- * (<group>-options 'help)
- * (<group>-options 'full)
- *
- * to display current option settings (The second version also
- * displays documentation. The third version also displays
- * information about programmer's options.), and
- *
- * (<group>-enable '<option-symbol>)
- * (<group>-disable '<option-symbol>)
- * (<group>-set! <option-symbol> <value>)
- * (<group>-options <option setting>)
- *
- * to alter the state of an option (The last version sets all
- * options according to <option setting>.) where <group> is the name
- * of the option group.
- *
- * An "option setting" represents the state of all low-level options
- * managed by one options interface procedure. It is a list of
- * single symbols and symbols followed by a value.
- *
- * For boolean options, the presence of the symbol of that option in
- * the option setting indicates a true value. If the symbol isn't a
- * member of the option setting this represents a false value.
- *
- * Other options are represented by a symbol followed by the value.
- *
- * If scm_options is called without arguments, the current option
- * setting is returned. If the argument is an option setting, options
- * are altered and the old setting is returned. If the argument isn't
- * a list, a list of sublists is returned, where each sublist contains
- * option name, value and documentation string.
- */
-
-SCM_SYMBOL (scm_yes_sym, "yes");
-SCM_SYMBOL (scm_no_sym, "no");
-
-
-SCM
-scm_options (new_mode, options, n, s)
- SCM new_mode;
- scm_option options[];
- int n;
- char *s;
-{
- int i, docp = (!SCM_UNBNDP (new_mode)
- && (SCM_IMP (new_mode) || SCM_NCONSP (new_mode)));
- SCM ans = SCM_EOL, ls;
- for (i = 0; i < n; ++i)
- {
- ls = docp ? scm_cons ((SCM) options[i].doc, SCM_EOL) : ans;
- switch (options[i].type)
- {
- case SCM_OPTION_BOOLEAN:
- if (docp)
- ls = scm_cons ((int) options[i].val
- ? scm_yes_sym
- : scm_no_sym,
- ls);
- break;
- case SCM_OPTION_INTEGER:
- ls = scm_cons (SCM_MAKINUM ((int) options[i].val), ls);
- break;
- case SCM_OPTION_SCM:
- ls = scm_cons ((SCM) options[i].val, ls);
- }
- if (!((options[i].type == SCM_OPTION_BOOLEAN)
- && !docp
- && ! (int) options[i].val))
- ls = scm_cons ((SCM) options[i].name, ls);
- ans = docp ? scm_cons (ls, ans) : ls;
- }
- if (!(SCM_UNBNDP (new_mode) || docp))
- {
- unsigned long *flags;
- flags = (unsigned long *) scm_must_malloc (n * sizeof (unsigned long),
- "mode buffer");
- for (i = 0; i < n; ++i)
- if (options[i].type == SCM_OPTION_BOOLEAN)
- flags[i] = 0;
- else
- flags[i] = (unsigned long) options[i].val;
- while (SCM_NNULLP (new_mode))
- {
- SCM_ASSERT (SCM_NIMP (new_mode) && SCM_CONSP (new_mode),
- new_mode,
- SCM_ARG1,
- s);
- for (i = 0; i < n; ++i)
- if (SCM_CAR (new_mode) == (SCM) options[i].name)
- switch (options[i].type)
- {
- case SCM_OPTION_BOOLEAN:
- flags[i] = 1;
- goto cont;
- case SCM_OPTION_INTEGER:
- new_mode = SCM_CDR (new_mode);
- SCM_ASSERT (SCM_NIMP (new_mode)
- && SCM_CONSP (new_mode)
- && SCM_INUMP (SCM_CAR (new_mode)),
- new_mode,
- SCM_ARG1,
- s);
- flags[i] = (unsigned long) SCM_INUM (SCM_CAR (new_mode));
- goto cont;
- case SCM_OPTION_SCM:
- new_mode = SCM_CDR (new_mode);
- flags[i] = SCM_CAR (new_mode);
- goto cont;
- }
-#ifndef RECKLESS
- scm_must_free ((char *) flags);
- scm_wta (SCM_CAR (new_mode), "Unknown mode flag", s);
-#endif
- cont:
- new_mode = SCM_CDR (new_mode);
- }
- for (i = 0; i < n; ++i) options[i].val = flags[i];
- scm_must_free ((char *) flags);
- }
- return ans;
-}
-
-
-void
-scm_init_opts (func, options, n)
- SCM (*func) (SCM);
- scm_option options[];
- int n;
-{
- int i;
-
- for (i = 0; i < n; ++i)
- {
- options[i].name = (char *) SCM_CAR (scm_sysintern (options[i].name,
- SCM_UNDEFINED));
- options[i].doc = (char *) scm_permanent_object (scm_take0str
- (options[i].doc));
- }
- func (SCM_UNDEFINED);
-}
-
-
-void
-scm_init_options ()
-{
-#include "options.x"
-}
diff --git a/libguile/options.h b/libguile/options.h
deleted file mode 100644
index 62b0a7436..000000000
--- a/libguile/options.h
+++ /dev/null
@@ -1,73 +0,0 @@
-/* classes: h_files */
-
-#ifndef OPTIONSH
-#define OPTIONSH
-/* Copyright (C) 1995,1996 Mikael Djurfeldt
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- *
- * The author can be reached at djurfeldt@nada.kth.se
- * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-typedef struct scm_option
-{
- int type;
- char *name;
- unsigned long val;
- char *doc;
-} scm_option;
-
-#define SCM_OPTION_BOOLEAN 0
-#define SCM_OPTION_INTEGER 1
-#define SCM_OPTION_SCM 2
-
-extern SCM scm_yes_sym, scm_no_sym;
-
-
-extern SCM scm_options SCM_P ((SCM new_mode, scm_option options[], int n, char *s));
-extern void scm_init_opts SCM_P ((SCM (*func) (SCM), scm_option options[], int n));
-extern void scm_init_options SCM_P ((void));
-
-#endif /* OPTIONSH */
diff --git a/libguile/pairs.c b/libguile/pairs.c
deleted file mode 100644
index 619529e64..000000000
--- a/libguile/pairs.c
+++ /dev/null
@@ -1,163 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include <stdio.h>
-#include "_scm.h"
-
-
-
-/* {Pairs}
- */
-
-SCM_PROC(s_cons, "cons", 2, 0, 0, scm_cons);
-
-SCM
-scm_cons (x, y)
- SCM x;
- SCM y;
-{
- register SCM z;
- SCM_NEWCELL (z);
- SCM_SETCAR (z, x);
- SCM_SETCDR (z, y);
- return z;
-}
-
-
-SCM
-scm_cons2 (w, x, y)
- SCM w;
- SCM x;
- SCM y;
-{
- register SCM z;
- SCM_NEWCELL (z);
- SCM_SETCAR (z, x);
- SCM_SETCDR (z, y);
- x = z;
- SCM_NEWCELL (z);
- SCM_SETCAR (z, w);
- SCM_SETCDR (z, x);
- return z;
-}
-
-
-SCM_PROC(s_pair_p, "pair?", 1, 0, 0, scm_pair_p);
-
-SCM
-scm_pair_p(x)
- SCM x;
-{
- if SCM_IMP(x) return SCM_BOOL_F;
- return SCM_CONSP(x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_set_car_x, "set-car!", 2, 0, 0, scm_set_car_x);
-
-SCM
-scm_set_car_x(pair, value)
- SCM pair;
- SCM value;
-{
- SCM_ASSERT(SCM_NIMP(pair) && SCM_CONSP(pair), pair, SCM_ARG1, s_set_car_x);
- SCM_SETCAR (pair, value);
- return value;
-}
-
-SCM_PROC(s_set_cdr_x, "set-cdr!", 2, 0, 0, scm_set_cdr_x);
-
-SCM
-scm_set_cdr_x(pair, value)
- SCM pair;
- SCM value;
-{
- SCM_ASSERT(SCM_NIMP(pair) && SCM_CONSP(pair), pair, SCM_ARG1, s_set_cdr_x);
- SCM_SETCDR (pair, value);
- return value;
-}
-
-
-
-
-static scm_iproc cxrs[] =
-{
- {"car", 0},
- {"cdr", 0},
- {"caar", 0},
- {"cadr", 0},
- {"cdar", 0},
- {"cddr", 0},
- {"caaar", 0},
- {"caadr", 0},
- {"cadar", 0},
- {"caddr", 0},
- {"cdaar", 0},
- {"cdadr", 0},
- {"cddar", 0},
- {"cdddr", 0},
- {"caaaar", 0},
- {"caaadr", 0},
- {"caadar", 0},
- {"caaddr", 0},
- {"cadaar", 0},
- {"cadadr", 0},
- {"caddar", 0},
- {"cadddr", 0},
- {"cdaaar", 0},
- {"cdaadr", 0},
- {"cdadar", 0},
- {"cdaddr", 0},
- {"cddaar", 0},
- {"cddadr", 0},
- {"cdddar", 0},
- {"cddddr", 0},
- {0, 0}
-};
-
-
-
-void
-scm_init_pairs ()
-{
- scm_init_iprocs(cxrs, scm_tc7_cxr);
-#include "pairs.x"
-}
-
diff --git a/libguile/pairs.h b/libguile/pairs.h
deleted file mode 100644
index ec074f77b..000000000
--- a/libguile/pairs.h
+++ /dev/null
@@ -1,172 +0,0 @@
-/* classes: h_files */
-
-#ifndef PAIRSH
-#define PAIRSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-typedef struct scm_cell
-{
- SCM car;
- SCM cdr;
-} scm_cell;
-
-/* SCM_PTR_LT defines how to compare two SCM_CELLPTRs (which may not be in the
- * same scm_array). SCM_CELLPTR is a pointer to a cons cell which may be
- * compared or differenced. SCMPTR is used for stack bounds.
- */
-
-#if !defined(__TURBOC__) || defined(__TOS__)
-
-typedef scm_cell *SCM_CELLPTR;
-typedef SCM *SCMPTR;
-
-# ifdef nosve
-# define SCM_PTR_MASK 0xffffffffffff
-# define SCM_PTR_LT(x, y) (((int)(x)&SCM_PTR_MASK) < ((int)(y)&SCM_PTR_MASK))
-# else
-# define SCM_PTR_LT(x, y) ((x) < (y))
-# endif /* def nosve */
-
-#else /* defined(__TURBOC__) && !defined(__TOS__) */
-
-# ifdef PROT386
-typedef scm_cell *SCM_CELLPTR;
-typedef SCM *SCMPTR;
-# define SCM_PTR_LT(x, y) (((long)(x)) < ((long)(y)))
-# else
-typedef scm_cell huge *SCM_CELLPTR;
-typedef SCM huge *SCMPTR;
-# define SCM_PTR_LT(x, y) ((x) < (y))
-# endif /* def PROT386 */
-
-#endif /* defined(__TURBOC__) && !defined(__TOS__) */
-
-#define SCM_PTR_GT(x, y) SCM_PTR_LT(y, x)
-#define SCM_PTR_LE(x, y) (!SCM_PTR_GT(x, y))
-#define SCM_PTR_GE(x, y) (!SCM_PTR_LT(x, y))
-
-#define SCM_NULLP(x) (SCM_EOL == (x))
-#define SCM_NNULLP(x) (SCM_EOL != (x))
-
-
-
-
-/* Cons Pairs
- */
-
-#define SCM_CAR(x) (((scm_cell *)(SCM2PTR(x)))->car)
-#define SCM_CDR(x) (((scm_cell *)(SCM2PTR(x)))->cdr)
-#define SCM_GCCDR(x) (~1L & SCM_CDR(x))
-#define SCM_SETCAR(x, v) (SCM_CAR(x) = (SCM)(v))
-#define SCM_SETCDR(x, v) (SCM_CDR(x) = (SCM)(v))
-
-#define SCM_CARLOC(x) (&SCM_CAR (x))
-#define SCM_CDRLOC(x) (&SCM_CDR (x))
-
-#define SCM_SETAND_CAR(x, y) (SCM_CAR (x) &= (y))
-#define SCM_SETAND_CDR(x, y) (SCM_CDR (x) &= (y))
-#define SCM_SETOR_CAR(x, y) (SCM_CAR (x) |= (y))
-#define SCM_SETOR_CDR(x, y) (SCM_CDR (x) |= (y))
-
-#define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ))
-#define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ))
-#define SCM_CADR(OBJ) SCM_CAR (SCM_CDR (OBJ))
-#define SCM_CDDR(OBJ) SCM_CDR (SCM_CDR (OBJ))
-
-#define SCM_CAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (OBJ)))
-#define SCM_CDAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (OBJ)))
-#define SCM_CADAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (OBJ)))
-#define SCM_CDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (OBJ)))
-#define SCM_CAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (OBJ)))
-#define SCM_CDADR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (OBJ)))
-#define SCM_CADDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (OBJ)))
-#define SCM_CDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (OBJ)))
-
-#define SCM_CAAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ))))
-#define SCM_CDAAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ))))
-#define SCM_CADAAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ))))
-#define SCM_CDDAAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ))))
-#define SCM_CAADAR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ))))
-#define SCM_CDADAR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ))))
-#define SCM_CADDAR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ))))
-#define SCM_CDDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ))))
-#define SCM_CAAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ))))
-#define SCM_CDAADR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ))))
-#define SCM_CADADR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ))))
-#define SCM_CDDADR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ))))
-#define SCM_CAADDR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ))))
-#define SCM_CDADDR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ))))
-#define SCM_CADDDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ))))
-#define SCM_CDDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ))))
-
-
-#ifdef DEBUG_FREELIST
-#define SCM_NEWCELL(_into) (scm_debug_newcell (&_into))
-#else
-#define SCM_NEWCELL(_into) \
- { \
- if (SCM_IMP(scm_freelist)) \
- _into = scm_gc_for_newcell();\
- else \
- { \
- _into = scm_freelist; \
- scm_freelist = SCM_CDR(scm_freelist);\
- ++scm_cells_allocated; \
- } \
- }
-#endif
-
-
-
-extern SCM scm_cons SCM_P ((SCM x, SCM y));
-extern SCM scm_cons2 SCM_P ((SCM w, SCM x, SCM y));
-extern SCM scm_pair_p SCM_P ((SCM x));
-extern SCM scm_set_car_x SCM_P ((SCM pair, SCM value));
-extern SCM scm_set_cdr_x SCM_P ((SCM pair, SCM value));
-extern void scm_init_pairs SCM_P ((void));
-
-#endif /* PAIRSH */
diff --git a/libguile/ports.c b/libguile/ports.c
deleted file mode 100644
index c2a9406e6..000000000
--- a/libguile/ports.c
+++ /dev/null
@@ -1,854 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include <stdio.h>
-#include "_scm.h"
-#include "genio.h"
-#include "chars.h"
-
-#include "markers.h"
-#include "filesys.h"
-#include "fports.h"
-#include "strports.h"
-#include "vports.h"
-
-#include "ports.h"
-
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_SYS_IOCTL_H
-#include <sys/ioctl.h>
-#endif
-
-
-
-/* scm_ptobs scm_numptob
- * implement a dynamicly resized array of ptob records.
- * Indexes into this table are used when generating type
- * tags for smobjects (if you know a tag you can get an index and conversely).
- */
-scm_ptobfuns *scm_ptobs;
-scm_sizet scm_numptob;
-
-
-SCM
-scm_markstream (ptr)
- SCM ptr;
-{
- int openp;
- if (SCM_GC8MARKP (ptr))
- return SCM_BOOL_F;
- openp = SCM_CAR (ptr) & SCM_OPN;
- SCM_SETGC8MARK (ptr);
- if (openp)
- return SCM_STREAM (ptr);
- else
- return SCM_BOOL_F;
-}
-
-
-
-long
-scm_newptob (ptob)
- scm_ptobfuns *ptob;
-{
- char *tmp;
- if (255 <= scm_numptob)
- goto ptoberr;
- SCM_DEFER_INTS;
- SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs, (1 + scm_numptob) * sizeof (scm_ptobfuns)));
- if (tmp)
- {
- scm_ptobs = (scm_ptobfuns *) tmp;
- scm_ptobs[scm_numptob].mark = ptob->mark;
- scm_ptobs[scm_numptob].free = ptob->free;
- scm_ptobs[scm_numptob].print = ptob->print;
- scm_ptobs[scm_numptob].equalp = ptob->equalp;
- scm_ptobs[scm_numptob].fputc = ptob->fputc;
- scm_ptobs[scm_numptob].fputs = ptob->fputs;
- scm_ptobs[scm_numptob].fwrite = ptob->fwrite;
- scm_ptobs[scm_numptob].fflush = ptob->fflush;
- scm_ptobs[scm_numptob].fgetc = ptob->fgetc;
- scm_ptobs[scm_numptob].fclose = ptob->fclose;
- scm_numptob++;
- }
- SCM_ALLOW_INTS;
- if (!tmp)
- ptoberr:scm_wta (SCM_MAKINUM ((long) scm_numptob), (char *) SCM_NALLOC, "newptob");
- return scm_tc7_port + (scm_numptob - 1) * 256;
-}
-
-
-/* internal SCM call */
-
-void
-scm_fflush (port)
- SCM port;
-{
- scm_sizet i = SCM_PTOBNUM (port);
- (scm_ptobs[i].fflush) (SCM_STREAM (port));
-}
-
-
-
-SCM_PROC(s_char_ready_p, "char-ready?", 1, 0, 0, scm_char_ready_p);
-
-SCM
-scm_char_ready_p (port)
- SCM port;
-{
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_char_ready_p);
- if (SCM_CRDYP (port) || !SCM_FPORTP (port))
- return SCM_BOOL_T;
- return (scm_input_waiting_p ((FILE *) SCM_STREAM (port), s_char_ready_p)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-
-
-SCM_PROC (s_ungetc_char_ready_p, "ungetc-char-ready?", 1, 0, 0, scm_ungetc_char_ready_p);
-
-SCM
-scm_ungetc_char_ready_p (port)
- SCM port;
-{
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_ungetc_char_ready_p);
- return (SCM_CRDYP (port)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-
-
-
-/* {Standard Ports}
- */
-SCM_PROC(s_current_input_port, "current-input-port", 0, 0, 0, scm_current_input_port);
-
-SCM
-scm_current_input_port ()
-{
- return scm_cur_inp;
-}
-
-SCM_PROC(s_current_output_port, "current-output-port", 0, 0, 0, scm_current_output_port);
-
-SCM
-scm_current_output_port ()
-{
- return scm_cur_outp;
-}
-
-SCM_PROC(s_current_error_port, "current-error-port", 0, 0, 0, scm_current_error_port);
-
-SCM
-scm_current_error_port ()
-{
- return scm_cur_errp;
-}
-
-SCM_PROC(s_set_current_input_port, "set-current-input-port", 1, 0, 0, scm_set_current_input_port);
-
-SCM
-scm_set_current_input_port (port)
- SCM port;
-{
- SCM oinp = scm_cur_inp;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_set_current_input_port);
- scm_cur_inp = port;
- return oinp;
-}
-
-
-SCM_PROC(s_set_current_output_port, "set-current-output-port", 1, 0, 0, scm_set_current_output_port);
-
-SCM
-scm_set_current_output_port (port)
- SCM port;
-{
- SCM ooutp = scm_cur_outp;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_output_port);
- scm_cur_outp = port;
- return ooutp;
-}
-
-
-SCM_PROC(s_set_current_error_port, "set-current-error-port", 1, 0, 0, scm_set_current_error_port);
-
-SCM
-scm_set_current_error_port (port)
- SCM port;
-{
- SCM oerrp = scm_cur_errp;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_set_current_error_port);
- scm_cur_errp = port;
- return oerrp;
-}
-
-
-
-/* {Ports - in general}
- *
- */
-
-/* Array of open ports, required for reliable MOVE->FDES etc. */
-struct scm_port_table **scm_port_table;
-
-int scm_port_table_size = 0; /* Number of ports in scm_port_table. */
-int scm_port_table_room = 20; /* Size of the array. */
-
-/* Add a port to the table. Call with SCM_DEFER_INTS active. */
-
-struct scm_port_table *
-scm_add_to_port_table (port)
- SCM port;
-{
- if (scm_port_table_size == scm_port_table_room)
- {
- scm_port_table = ((struct scm_port_table **)
- realloc ((char *) scm_port_table,
- (long) (sizeof (struct scm_port_table)
- * scm_port_table_room * 2)));
- /* !!! error checking */
- scm_port_table_room *= 2;
- }
- scm_port_table[scm_port_table_size] = ((struct scm_port_table *)
- scm_must_malloc (sizeof (struct scm_port_table),
- "system port table"));
- scm_port_table[scm_port_table_size]->port = port;
- scm_port_table[scm_port_table_size]->revealed = 0;
- scm_port_table[scm_port_table_size]->stream = 0;
- scm_port_table[scm_port_table_size]->file_name = SCM_BOOL_F;
- scm_port_table[scm_port_table_size]->line_number = 1;
- scm_port_table[scm_port_table_size]->column_number = 0;
- scm_port_table[scm_port_table_size]->representation = scm_regular_port;
- return scm_port_table[scm_port_table_size++];
-}
-
-/* Remove a port from the table. Call with SCM_DEFER_INTS active. */
-
-void
-scm_remove_from_port_table (port)
- SCM port;
-{
- int i = 0;
- while (scm_port_table[i]->port != port)
- {
- i++;
- /* Error if not found: too violent? May occur in GC. */
- if (i >= scm_port_table_size)
- scm_wta (port, "Port not in table", "scm_remove_from_port_table");
- }
- scm_must_free ((char *)scm_port_table[i]);
- scm_mallocated -= sizeof (*scm_port_table[i]);
- scm_port_table[i] = scm_port_table[scm_port_table_size - 1];
- SCM_SETPTAB_ENTRY (port, 0);
- scm_port_table_size--;
-}
-
-#ifdef DEBUG
-/* Undocumented functions for debugging. */
-/* Return the number of ports in the table. */
-static char s_pt_size[] = "pt-size";
-
-SCM
-scm_pt_size ()
-{
- return SCM_MAKINUM (scm_port_table_size);
-}
-
-/* Return the ith member of the port table. */
-static char s_pt_member[] = "pt-member";
-
-SCM
-scm_pt_member (member)
- SCM member;
-{
- int i;
- SCM_ASSERT (SCM_INUMP (member), member, SCM_ARG1, s_pt_member);
- i = SCM_INUM (member);
- if (i < 0 || i >= scm_port_table_size)
- return SCM_BOOL_F;
- else
- return scm_port_table[i]->port;
-}
-#endif
-
-
-/* Find a port in the table and return its revealed count.
- Also used by the garbage collector.
- */
-
-int
-scm_revealed_count (port)
- SCM port;
-{
- return SCM_REVEALED(port);
-}
-
-
-
-/* Return the revealed count for a port. */
-
-SCM_PROC(s_port_revealed, "port-revealed", 1, 0, 0, scm_port_revealed);
-
-SCM
-scm_port_revealed (port)
- SCM port;
-{
- SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_port_revealed);
- return SCM_MAKINUM (scm_revealed_count (port));
-}
-
-/* Set the revealed count for a port. */
-SCM_PROC(s_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, scm_set_port_revealed_x);
-
-SCM
-scm_set_port_revealed_x (port, rcount)
- SCM port;
- SCM rcount;
-{
- SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_set_port_revealed_x);
- SCM_ASSERT (SCM_INUMP (rcount), rcount, SCM_ARG2, s_set_port_revealed_x);
- SCM_DEFER_INTS;
- SCM_REVEALED (port) = SCM_INUM (rcount);
- SCM_ALLOW_INTS;
- return SCM_UNSPECIFIED;
-}
-
-/* scm_close_port
- * Call the close operation on a port object.
- */
-SCM_PROC(s_close_port, "close-port", 1, 0, 0, scm_close_port);
-
-SCM
-scm_close_port (port)
- SCM port;
-{
- scm_sizet i;
- SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port), port, SCM_ARG1, s_close_port);
- if (SCM_CLOSEDP (port))
- return SCM_UNSPECIFIED;
- i = SCM_PTOBNUM (port);
- SCM_DEFER_INTS;
- if (scm_ptobs[i].fclose)
- SCM_SYSCALL ((scm_ptobs[i].fclose) (SCM_STREAM (port)));
- scm_remove_from_port_table (port);
- SCM_SETAND_CAR (port, ~SCM_OPN);
- SCM_ALLOW_INTS;
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC(s_close_all_ports_except, "close-all-ports-except", 0, 0, 1, scm_close_all_ports_except);
-
-SCM
-scm_close_all_ports_except (ports)
- SCM ports;
-{
- int i = 0;
- SCM_ASSERT (SCM_NIMP (ports) && SCM_CONSP (ports), ports, SCM_ARG1, s_close_all_ports_except);
- SCM_DEFER_INTS;
- while (i < scm_port_table_size)
- {
- SCM thisport = scm_port_table[i]->port;
- int found = 0;
- SCM ports_ptr = ports;
-
- while (SCM_NNULLP (ports_ptr))
- {
- SCM port = SCM_CAR (ports_ptr);
- if (i == 0)
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_close_all_ports_except);
- if (port == thisport)
- found = 1;
- ports_ptr = SCM_CDR (ports_ptr);
- }
- if (found)
- i++;
- else
- /* i is not to be incremented here. */
- scm_close_port (thisport);
- }
- SCM_ALLOW_INTS;
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC(s_input_port_p, "input-port?", 1, 0, 0, scm_input_port_p);
-
-SCM
-scm_input_port_p (x)
- SCM x;
-{
- if (SCM_IMP (x))
- return SCM_BOOL_F;
- return SCM_INPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_output_port_p, "output-port?", 1, 0, 0, scm_output_port_p);
-
-SCM
-scm_output_port_p (x)
- SCM x;
-{
- if (SCM_IMP (x))
- return SCM_BOOL_F;
- return SCM_OUTPORTP (x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-
-SCM_PROC(s_eof_object_p, "eof-object?", 1, 0, 0, scm_eof_object_p);
-
-SCM
-scm_eof_object_p (x)
- SCM x;
-{
- return (SCM_EOF_VAL == x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_force_output, "force-output", 0, 1, 0, scm_force_output);
-
-SCM
-scm_force_output (port)
- SCM port;
-{
- if (SCM_UNBNDP (port))
- port = scm_cur_outp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_force_output);
- {
- scm_sizet i = SCM_PTOBNUM (port);
- SCM_SYSCALL ((scm_ptobs[i].fflush) (SCM_STREAM (port)));
- return SCM_UNSPECIFIED;
- }
-}
-
-
-SCM_PROC(s_read_char, "read-char", 0, 1, 0, scm_read_char);
-
-SCM
-scm_read_char (port)
- SCM port;
-{
- int c;
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_char);
- c = scm_gen_getc (port);
- if (EOF == c)
- return SCM_EOF_VAL;
- return SCM_MAKICHR (c);
-}
-
-
-SCM_PROC(s_peek_char, "peek-char", 0, 1, 0, scm_peek_char);
-
-SCM
-scm_peek_char (port)
- SCM port;
-{
- int c;
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_peek_char);
- c = scm_gen_getc (port);
- if (EOF == c)
- return SCM_EOF_VAL;
- scm_gen_ungetc (c, port);
- return SCM_MAKICHR (c);
-}
-
-SCM_PROC (s_unread_char, "unread-char", 2, 0, 0, scm_unread_char);
-
-SCM
-scm_unread_char (cobj, port)
- SCM cobj;
- SCM port;
-{
- int c;
-
- SCM_ASSERT (SCM_ICHRP (cobj), cobj, SCM_ARG1, s_unread_char);
-
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_unread_char);
-
-
- c = SCM_ICHR (cobj);
-
- scm_gen_ungetc (c, port);
- return cobj;
-}
-
-
-
-SCM_PROC (s_port_line, "port-line", 0, 1, 0, scm_port_line);
-
-SCM
-scm_port_line (port)
- SCM port;
-{
- SCM p;
- p = ((port == SCM_UNDEFINED)
- ? scm_cur_inp
- : port);
- if (!(SCM_NIMP (p) && SCM_PORTP (p)))
- return SCM_BOOL_F;
- else
- return SCM_MAKINUM (SCM_LINUM (p));
-}
-
-SCM_PROC (s_set_port_line_x, "set-port-line!", 1, 1, 0, scm_set_port_line_x);
-
-SCM
-scm_set_port_line_x (port, line)
- SCM port;
- SCM line;
-{
- if (line == SCM_UNDEFINED)
- {
- line = port;
- port = scm_cur_inp;
- }
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
- port,
- SCM_ARG1,
- s_set_port_line_x);
- return SCM_PTAB_ENTRY (port)->line_number = SCM_INUM (line);
-}
-
-SCM_PROC (s_port_column, "port-column", 0, 1, 0, scm_port_column);
-
-SCM
-scm_port_column (port)
- SCM port;
-{
- SCM p;
- p = ((port == SCM_UNDEFINED)
- ? scm_cur_inp
- : port);
- if (!(SCM_NIMP (p) && SCM_PORTP (p)))
- return SCM_BOOL_F;
- else
- return SCM_MAKINUM (SCM_COL (p));
-}
-
-SCM_PROC (s_set_port_column_x, "set-port-column!", 1, 1, 0, scm_set_port_column_x);
-
-SCM
-scm_set_port_column_x (port, column)
- SCM port;
- SCM column;
-{
- if (column == SCM_UNDEFINED)
- {
- column = port;
- port = scm_cur_inp;
- }
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
- port,
- SCM_ARG1,
- s_set_port_column_x);
- return SCM_PTAB_ENTRY (port)->column_number = SCM_INUM (column);
-}
-
-SCM_PROC (s_port_filename, "port-filename", 0, 1, 0, scm_port_filename);
-
-SCM
-scm_port_filename (port)
- SCM port;
-{
- SCM p;
- p = ((port == SCM_UNDEFINED)
- ? scm_cur_inp
- : port);
- if (!(SCM_NIMP (p) && SCM_PORTP (p)))
- return SCM_BOOL_F;
- else
- return SCM_PTAB_ENTRY (p)->file_name;
-}
-
-SCM_PROC (s_set_port_filename_x, "set-port-filename!", 1, 1, 0, scm_set_port_filename_x);
-
-SCM
-scm_set_port_filename_x (port, filename)
- SCM port;
- SCM filename;
-{
- if (filename == SCM_UNDEFINED)
- {
- filename = port;
- port = scm_cur_inp;
- }
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_PORTP (port) && SCM_OPENP (port),
- port,
- SCM_ARG1,
- s_set_port_filename_x);
- return SCM_PTAB_ENTRY (port)->file_name = filename;
-}
-
-#ifndef ttyname
-extern char * ttyname();
-#endif
-
-
-void
-scm_prinport (exp, port, type)
- SCM exp;
- SCM port;
- char *type;
-{
- scm_gen_puts (scm_regular_string, "#<", port);
- if (SCM_CLOSEDP (exp))
- scm_gen_puts (scm_regular_string, "closed: ", port);
- else
- {
- if (SCM_RDNG & SCM_CAR (exp))
- scm_gen_puts (scm_regular_string, "input: ", port);
- if (SCM_WRTNG & SCM_CAR (exp))
- scm_gen_puts (scm_regular_string, "output: ", port);
- }
- scm_gen_puts (scm_regular_string, type, port);
- scm_gen_putc (' ', port);
-#ifndef MSDOS
-#ifndef __EMX__
-#ifndef _DCC
-#ifndef AMIGA
-#ifndef THINK_C
- if (SCM_OPENP (exp) && scm_tc16_fport == SCM_TYP16 (exp) && isatty (fileno ((FILE *)SCM_STREAM (exp))))
- scm_gen_puts (scm_regular_string, ttyname (fileno ((FILE *)SCM_STREAM (exp))), port);
- else
-#endif
-#endif
-#endif
-#endif
-#endif
- if (SCM_OPFPORTP (exp))
- scm_intprint ((long) fileno ((FILE *)SCM_STREAM (exp)), 10, port);
- else
- scm_intprint (SCM_CDR (exp), 16, port);
- scm_gen_putc ('>', port);
-}
-
-
-void
-scm_ports_prehistory ()
-{
- scm_numptob = 0;
- scm_ptobs = (scm_ptobfuns *) malloc (sizeof (scm_ptobfuns));
-
- /* WARNING: These scm_newptob calls must be done in this order.
- * They must agree with the port declarations in tags.h.
- */
- /* scm_tc16_fport = */ scm_newptob (&scm_fptob);
- /* scm_tc16_pipe = */ scm_newptob (&scm_pipob);
- /* scm_tc16_strport = */ scm_newptob (&scm_stptob);
- /* scm_tc16_sfport = */ scm_newptob (&scm_sfptob);
-}
-
-
-
-/* {Void Ports}
- */
-
-int scm_tc16_void_port = 0;
-
-static int
-print_void_port (exp, port, writing)
- SCM exp;
- SCM port;
- int writing;
-{
- scm_prinport (exp, port, "void");
- return 1;
-}
-
-static int
-putc_void_port (c, strm)
- int c;
- SCM strm;
-{
- return 0; /* vestigial return value */
-}
-
-static int
-puts_void_port (s, strm)
- char * s;
- SCM strm;
-{
- return 0; /* vestigial return value */
-}
-
-static scm_sizet
-write_void_port (ptr, size, nitems, strm)
- void * ptr;
- int size;
- int nitems;
- SCM strm;
-{
- int len;
- len = size * nitems;
- return len;
-}
-
-
-static int flush_void_port SCM_P ((SCM strm));
-
-static int
-flush_void_port (strm)
- SCM strm;
-{
- return 0;
-}
-
-
-static int getc_void_port SCM_P ((SCM strm));
-
-static int
-getc_void_port (strm)
- SCM strm;
-{
- return EOF;
-}
-
-
-static int close_void_port SCM_P ((SCM strm));
-
-static int
-close_void_port (strm)
- SCM strm;
-{
- return 0; /* this is ignored by scm_close_port. */
-}
-
-
-
-static int noop0 SCM_P ((SCM stream));
-
-static int
-noop0 (stream)
- SCM stream;
-{
- return 0;
-}
-
-
-static struct scm_ptobfuns void_port_ptob =
-{
- scm_mark0,
- noop0,
- print_void_port,
- 0, /* equal? */
- putc_void_port,
- puts_void_port,
- write_void_port,
- flush_void_port,
- getc_void_port,
- close_void_port,
-};
-
-
-
-
-SCM
-scm_void_port (mode_str)
- char * mode_str;
-{
- int mode_bits;
- SCM answer;
- struct scm_port_table * pt;
-
- SCM_NEWCELL (answer);
- SCM_DEFER_INTS;
- mode_bits = scm_mode_bits (mode_str);
- pt = scm_add_to_port_table (answer);
- SCM_SETCAR (answer, scm_tc16_void_port | mode_bits);
- SCM_SETPTAB_ENTRY (answer, pt);
- SCM_SETSTREAM (answer, SCM_BOOL_F);
- SCM_ALLOW_INTS;
- return answer;
-}
-
-
-SCM_PROC (s_sys_make_void_port, "%make-void-port", 1, 0, 0, scm_sys_make_void_port);
-
-SCM
-scm_sys_make_void_port (mode)
- SCM mode;
-{
- SCM_ASSERT (SCM_NIMP (mode) && SCM_STRINGP (mode), mode,
- SCM_ARG1, s_sys_make_void_port);
-
- return scm_void_port (SCM_ROCHARS (mode));
-}
-
-
-
-
-
-
-void
-scm_init_ports ()
-{
- scm_tc16_void_port = scm_newptob (&void_port_ptob);
-#include "ports.x"
-}
-
diff --git a/libguile/ports.h b/libguile/ports.h
deleted file mode 100644
index 55875b197..000000000
--- a/libguile/ports.h
+++ /dev/null
@@ -1,200 +0,0 @@
-/* classes: h_files */
-
-#ifndef PORTSH
-#define PORTSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-enum scm_port_representation_type
-{
- scm_regular_port,
- scm_mb_port,
- scm_wchar_port
-};
-
-enum scm_string_representation_type
-{
- scm_regular_string = scm_regular_port,
- scm_mb_string = scm_mb_port,
- scm_wchar_string = scm_wchar_port
-};
-
-
-struct scm_port_table
-{
- SCM port; /* Open port. */
- int revealed; /* 0 not revealed, > 1 revealed.
- * Revealed ports do not get GC'd.
- */
-
- SCM stream;
- SCM file_name; /* debugging support. */
- int unchr; /* pushed back character, if any */
-
- int line_number; /* debugging support. */
- int column_number; /* debugging support. */
-
- enum scm_port_representation_type representation;
-};
-
-extern struct scm_port_table **scm_port_table;
-extern int scm_port_table_size; /* Number of ports in scm_port_table. */
-
-
-
-
-/* PORT FLAGS
- * A set of flags characterizes a port.
- */
-#define SCM_OPN (1L<<16) /* Is the port open? */
-#define SCM_RDNG (2L<<16) /* Is it a readable port? */
-#define SCM_WRTNG (4L<<16) /* Is it writable? */
-#define SCM_BUF0 (8L<<16)
-#define SCM_CRDY (32L<<16) /* Should char-ready? return #t? */
-
-/* A mask used to clear the char-ready port flag. */
-#define SCM_CUC 0x001fffffL
-
-#define SCM_PORTP(x) (SCM_TYP7(x)==scm_tc7_port)
-#define SCM_OPPORTP(x) (((0x7f | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN))
-#define SCM_OPINPORTP(x) (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))
-#define SCM_OPOUTPORTP(x) (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))
-#define SCM_FPORTP(x) (SCM_TYP16S(x)==scm_tc7_port)
-#define SCM_OPFPORTP(x) (((0xfeff | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN))
-#define SCM_OPINFPORTP(x) (((0xfeff | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))
-#define SCM_OPOUTFPORTP(x) (((0xfeff | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))
-
-#define SCM_INPORTP(x) (((0x7f | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_RDNG))
-#define SCM_OUTPORTP(x) (((0x7f | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_WRTNG))
-#define SCM_OPENP(x) (SCM_OPN & SCM_CAR(x))
-#define SCM_CLOSEDP(x) (!SCM_OPENP(x))
-#define SCM_PTAB_ENTRY(x) ((struct scm_port_table *)SCM_CDR(x))
-#define SCM_SETPTAB_ENTRY(x,ent) SCM_SETCDR ((x), (SCM)(ent))
-#define SCM_STREAM(x) SCM_PTAB_ENTRY(x)->stream
-#define SCM_SETSTREAM(x,s) (SCM_PTAB_ENTRY(x)->stream = s)
-#define SCM_FILENAME(x) SCM_PTAB_ENTRY(x)->file_name
-#define SCM_LINUM(x) SCM_PTAB_ENTRY(x)->line_number
-#define SCM_COL(x) SCM_PTAB_ENTRY(x)->column_number
-#define SCM_REVEALED(x) SCM_PTAB_ENTRY(x)->revealed
-#define SCM_SETREVEALED(x,s) (SCM_PTAB_ENTRY(x)->revealed = s)
-#define SCM_PORT_REPRESENTATION(x) SCM_PTAB_ENTRY(x)->representation
-#define SCM_SET_PORT_REPRESENTATION(x,s) (SCM_PTAB_ENTRY(x)->representation = s)
-#define SCM_CRDYP(port) (SCM_CAR (port) & SCM_CRDY)
-#define SCM_CLRDY(port) {SCM_SETAND_CAR (port, SCM_CUC);}
-#define SCM_SETRDY(port) {SCM_SETOR_CAR (port, SCM_CRDY);}
-#define SCM_CUNGET(c,port) {SCM_PTAB_ENTRY(port)->unchr = c; SCM_SETRDY(port);}
-#define SCM_CGETUN(port) (SCM_PTAB_ENTRY(port)->unchr)
-
-#define SCM_INCLINE(port) {SCM_LINUM (port) += 1; SCM_COL (port) = 0;}
-#define SCM_INCCOL(port) {SCM_COL (port) += 1;}
-#define SCM_TABCOL(port) {SCM_COL (port) += 8 - SCM_COL (port) % 8;}
-
-
-
-
-
-typedef struct scm_ptobfuns
-{
- SCM (*mark) SCM_P ((SCM));
- int (*free) SCM_P ((SCM));
- int (*print) SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
- SCM (*equalp) SCM_P ((SCM, SCM));
- int (*fputc) SCM_P ((int, SCM stream));
- int (*fputs) SCM_P ((char *, SCM stream));
- scm_sizet (*fwrite) SCM_P ((char *ptr, scm_sizet size, scm_sizet nitems, SCM stream));
- int (*fflush) SCM_P ((SCM stream));
- int (*fgetc) SCM_P ((SCM stream));
- int (*fclose) SCM_P ((SCM stream));
-} scm_ptobfuns;
-
-#define SCM_PTOBNUM(x) (0x0ff & (SCM_CAR(x)>>8));
-
-
-
-extern scm_ptobfuns *scm_ptobs;
-extern scm_sizet scm_numptob;
-extern int scm_port_table_room;
-
-
-
-extern SCM scm_markstream SCM_P ((SCM ptr));
-extern long scm_newptob SCM_P ((scm_ptobfuns *ptob));
-extern void scm_fflush SCM_P ((SCM port));
-extern SCM scm_char_ready_p SCM_P ((SCM port));
-extern SCM scm_ungetc_char_ready_p SCM_P ((SCM port));
-extern SCM scm_current_input_port SCM_P ((void));
-extern SCM scm_current_output_port SCM_P ((void));
-extern SCM scm_current_error_port SCM_P ((void));
-extern SCM scm_set_current_input_port SCM_P ((SCM port));
-extern SCM scm_set_current_output_port SCM_P ((SCM port));
-extern SCM scm_set_current_error_port SCM_P ((SCM port));
-extern struct scm_port_table * scm_add_to_port_table SCM_P ((SCM port));
-extern void scm_remove_from_port_table SCM_P ((SCM port));
-extern SCM scm_pt_size SCM_P ((void));
-extern SCM scm_pt_member SCM_P ((SCM member));
-extern int scm_revealed_count SCM_P ((SCM port));
-extern SCM scm_port_revealed SCM_P ((SCM port));
-extern SCM scm_set_port_revealed_x SCM_P ((SCM port, SCM rcount));
-extern SCM scm_close_port SCM_P ((SCM port));
-extern SCM scm_close_all_ports_except SCM_P ((SCM ports));
-extern SCM scm_input_port_p SCM_P ((SCM x));
-extern SCM scm_output_port_p SCM_P ((SCM x));
-extern SCM scm_eof_object_p SCM_P ((SCM x));
-extern SCM scm_force_output SCM_P ((SCM port));
-extern SCM scm_read_char SCM_P ((SCM port));
-extern SCM scm_peek_char SCM_P ((SCM port));
-extern SCM scm_unread_char SCM_P ((SCM cobj, SCM port));
-extern SCM scm_port_line SCM_P ((SCM port));
-extern SCM scm_port_column SCM_P ((SCM port));
-extern SCM scm_port_filename SCM_P ((SCM port));
-extern SCM scm_set_port_filename_x SCM_P ((SCM port, SCM filename));
-extern void scm_prinport SCM_P ((SCM exp, SCM port, char *type));
-extern void scm_ports_prehistory SCM_P ((void));
-extern SCM scm_void_port SCM_P ((char * mode_str));
-extern SCM scm_sys_make_void_port SCM_P ((SCM mode));
-extern void scm_init_ports SCM_P ((void));
-
-#endif /* PORTSH */
diff --git a/libguile/posix.c b/libguile/posix.c
deleted file mode 100644
index ebdbf202c..000000000
--- a/libguile/posix.c
+++ /dev/null
@@ -1,1461 +0,0 @@
-/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "fports.h"
-#include "genio.h"
-#include "scmsigs.h"
-#include "read.h"
-#include "unif.h"
-#include "feature.h"
-#include "sequences.h"
-
-#include "posix.h"
-
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-#ifdef TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-#else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-#endif
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#else
-#ifndef ttyname
-extern char *ttyname();
-#endif
-#endif
-
-#ifdef LIBC_H_WITH_UNISTD_H
-#include <libc.h>
-#endif
-
-#ifdef HAVE_SYS_SELECT_H
-#include <sys/select.h>
-#endif
-
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <fcntl.h>
-
-#include <pwd.h>
-
-#if HAVE_SYS_WAIT_H
-# include <sys/wait.h>
-#endif
-#ifndef WEXITSTATUS
-# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
-#endif
-#ifndef WIFEXITED
-# define WIFEXITED(stat_val) (((stat_val) & 255) == 0)
-#endif
-
-#include <signal.h>
-
-#ifdef FD_SET
-
-#define SELECT_TYPE fd_set
-#define SELECT_SET_SIZE FD_SETSIZE
-
-#else /* no FD_SET */
-
-/* Define the macros to access a single-int bitmap of descriptors. */
-#define SELECT_SET_SIZE 32
-#define SELECT_TYPE int
-#define FD_SET(n, p) (*(p) |= (1 << (n)))
-#define FD_CLR(n, p) (*(p) &= ~(1 << (n)))
-#define FD_ISSET(n, p) (*(p) & (1 << (n)))
-#define FD_ZERO(p) (*(p) = 0)
-
-#endif /* no FD_SET */
-
-extern FILE *popen ();
-extern char ** environ;
-
-#include <grp.h>
-#include <sys/utsname.h>
-
-#if HAVE_DIRENT_H
-# include <dirent.h>
-# define NAMLEN(dirent) strlen((dirent)->d_name)
-#else
-# define dirent direct
-# define NAMLEN(dirent) (dirent)->d_namlen
-# if HAVE_SYS_NDIR_H
-# include <sys/ndir.h>
-# endif
-# if HAVE_SYS_DIR_H
-# include <sys/dir.h>
-# endif
-# if HAVE_NDIR_H
-# include <ndir.h>
-# endif
-#endif
-
-char *strptime ();
-
-#ifdef HAVE_SETLOCALE
-#include <locale.h>
-#endif
-
-/* Some Unix systems don't define these. CPP hair is dangerous, but
- this seems safe enough... */
-#ifndef R_OK
-#define R_OK 4
-#endif
-
-#ifndef W_OK
-#define W_OK 2
-#endif
-
-#ifndef X_OK
-#define X_OK 1
-#endif
-
-#ifndef F_OK
-#define F_OK 0
-#endif
-
-/* On NextStep, <utime.h> doesn't define struct utime, unless we
- #define _POSIX_SOURCE before #including it. I think this is less
- of a kludge than defining struct utimbuf ourselves. */
-#ifdef UTIMBUF_NEEDS_POSIX
-#define _POSIX_SOURCE
-#endif
-
-#ifdef HAVE_SYS_UTIME_H
-#include <sys/utime.h>
-#endif
-
-#ifdef HAVE_UTIME_H
-#include <utime.h>
-#endif
-
-/* Please don't add any more #includes or #defines here. The hack
- above means that _POSIX_SOURCE may be #defined, which will
- encourage header files to do strange things. */
-
-
-
-
-SCM_PROC (s_pipe, "pipe", 0, 0, 0, scm_pipe);
-
-SCM
-scm_pipe ()
-{
- int fd[2], rv;
- FILE *f_rd, *f_wt;
- SCM p_rd, p_wt;
- struct scm_port_table * ptr;
- struct scm_port_table * ptw;
-
- SCM_NEWCELL (p_rd);
- SCM_NEWCELL (p_wt);
- rv = pipe (fd);
- if (rv)
- scm_syserror (s_pipe);
- f_rd = fdopen (fd[0], "r");
- if (!f_rd)
- {
- SCM_SYSCALL (close (fd[0]));
- SCM_SYSCALL (close (fd[1]));
- scm_syserror (s_pipe);
- }
- f_wt = fdopen (fd[1], "w");
- if (!f_wt)
- {
- int en;
- en = errno;
- fclose (f_rd);
- SCM_SYSCALL (close (fd[1]));
- errno = en;
- scm_syserror (s_pipe);
- }
- ptr = scm_add_to_port_table (p_rd);
- ptw = scm_add_to_port_table (p_wt);
- SCM_SETPTAB_ENTRY (p_rd, ptr);
- SCM_SETPTAB_ENTRY (p_wt, ptw);
- SCM_SETCAR (p_rd, scm_tc16_fport | scm_mode_bits ("r"));
- SCM_SETCAR (p_wt, scm_tc16_fport | scm_mode_bits ("w"));
- SCM_SETSTREAM (p_rd, (SCM)f_rd);
- SCM_SETSTREAM (p_wt, (SCM)f_wt);
-
- SCM_ALLOW_INTS;
- return scm_cons (p_rd, p_wt);
-}
-
-
-
-SCM_PROC (s_getgroups, "getgroups", 0, 0, 0, scm_getgroups);
-
-SCM
-scm_getgroups()
-{
- SCM grps, ans;
- int ngroups = getgroups (0, NULL);
- if (!ngroups)
- scm_syserror (s_getgroups);
- SCM_NEWCELL(grps);
- SCM_DEFER_INTS;
- {
- GETGROUPS_T *groups;
- int val;
-
- groups = (GETGROUPS_T *) scm_must_malloc(ngroups * sizeof(GETGROUPS_T),
- s_getgroups);
- val = getgroups(ngroups, groups);
- if (val < 0)
- {
- scm_must_free((char *)groups);
- scm_syserror (s_getgroups);
- }
- SCM_SETCHARS(grps, groups); /* set up grps as a GC protect */
- SCM_SETLENGTH(grps, 0L + ngroups * sizeof(GETGROUPS_T), scm_tc7_string);
- SCM_ALLOW_INTS;
- ans = scm_make_vector(SCM_MAKINUM(ngroups), SCM_UNDEFINED, SCM_BOOL_F);
- while (--ngroups >= 0) SCM_VELTS(ans)[ngroups] = SCM_MAKINUM(groups[ngroups]);
- SCM_SETCHARS(grps, groups); /* to make sure grps stays around. */
- return ans;
- }
-}
-
-
-
-SCM_PROC (s_getpwuid, "getpw", 0, 1, 0, scm_getpwuid);
-
-SCM
-scm_getpwuid (user)
- SCM user;
-{
- SCM result;
- struct passwd *entry;
- SCM *ve;
-
- result = scm_make_vector (SCM_MAKINUM (7), SCM_UNSPECIFIED, SCM_BOOL_F);
- ve = SCM_VELTS (result);
- if (SCM_UNBNDP (user) || SCM_FALSEP (user))
- {
- SCM_DEFER_INTS;
- SCM_SYSCALL (entry = getpwent ());
- }
- else if (SCM_INUMP (user))
- {
- SCM_DEFER_INTS;
- entry = getpwuid (SCM_INUM (user));
- }
- else
- {
- SCM_ASSERT (SCM_NIMP (user) && SCM_ROSTRINGP (user), user, SCM_ARG1, s_getpwuid);
- if (SCM_SUBSTRP (user))
- user = scm_makfromstr (SCM_ROCHARS (user), SCM_ROLENGTH (user), 0);
- SCM_DEFER_INTS;
- entry = getpwnam (SCM_ROCHARS (user));
- }
- if (!entry)
- scm_syserror (s_getpwuid);
-
- ve[0] = scm_makfrom0str (entry->pw_name);
- ve[1] = scm_makfrom0str (entry->pw_passwd);
- ve[2] = scm_ulong2num ((unsigned long) entry->pw_uid);
- ve[3] = scm_ulong2num ((unsigned long) entry->pw_gid);
- ve[4] = scm_makfrom0str (entry->pw_gecos);
- if (!entry->pw_dir)
- ve[5] = scm_makfrom0str ("");
- else
- ve[5] = scm_makfrom0str (entry->pw_dir);
- if (!entry->pw_shell)
- ve[6] = scm_makfrom0str ("");
- else
- ve[6] = scm_makfrom0str (entry->pw_shell);
- SCM_ALLOW_INTS;
- return result;
-}
-
-
-
-SCM_PROC (s_setpwent, "setpw", 0, 1, 0, scm_setpwent);
-
-SCM
-scm_setpwent (arg)
- SCM arg;
-{
- if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
- endpwent ();
- else
- setpwent ();
- return SCM_UNSPECIFIED;
-}
-
-
-
-/* Combines getgrgid and getgrnam. */
-SCM_PROC (s_getgrgid, "getgr", 0, 1, 0, scm_getgrgid);
-
-SCM
-scm_getgrgid (name)
- SCM name;
-{
- SCM result;
- struct group *entry;
- SCM *ve;
- result = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
- ve = SCM_VELTS (result);
- SCM_DEFER_INTS;
- if (SCM_UNBNDP (name) || (name == SCM_BOOL_F))
- SCM_SYSCALL (entry = getgrent ());
- else if (SCM_INUMP (name))
- SCM_SYSCALL (entry = getgrgid (SCM_INUM (name)));
- else
- {
- SCM_ASSERT (SCM_NIMP (name) && SCM_STRINGP (name), name, SCM_ARG1, s_getgrgid);
- if (SCM_SUBSTRP (name))
- name = scm_makfromstr (SCM_ROCHARS (name), SCM_ROLENGTH (name), 0);
- SCM_SYSCALL (entry = getgrnam (SCM_CHARS (name)));
- }
- if (!entry)
- scm_syserror (s_getgrgid);
-
- ve[0] = scm_makfrom0str (entry->gr_name);
- ve[1] = scm_makfrom0str (entry->gr_passwd);
- ve[2] = scm_ulong2num ((unsigned long) entry->gr_gid);
- ve[3] = scm_makfromstrs (-1, entry->gr_mem);
- SCM_ALLOW_INTS;
- return result;
-}
-
-
-
-SCM_PROC (s_setgrent, "setgr", 0, 1, 0, scm_setgrent);
-
-SCM
-scm_setgrent (arg)
- SCM arg;
-{
- if (SCM_UNBNDP (arg) || SCM_FALSEP (arg))
- endgrent ();
- else
- setgrent ();
- return SCM_UNSPECIFIED;
-}
-
-
-
-SCM_PROC (s_kill, "kill", 2, 0, 0, scm_kill);
-
-SCM
-scm_kill (pid, sig)
- SCM pid;
- SCM sig;
-{
- SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_kill);
- SCM_ASSERT (SCM_INUMP (sig), sig, SCM_ARG2, s_kill);
- /* Signal values are interned in scm_init_posix(). */
- if (kill ((int) SCM_INUM (pid), (int) SCM_INUM (sig)) != 0)
- scm_syserror (s_kill);
- return SCM_UNSPECIFIED;
-}
-
-
-
-SCM_PROC (s_waitpid, "waitpid", 1, 1, 0, scm_waitpid);
-
-SCM
-scm_waitpid (pid, options)
- SCM pid;
- SCM options;
-{
-#ifdef HAVE_WAITPID
- int i;
- int status;
- int ioptions;
- SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_waitpid);
- if (SCM_UNBNDP (options))
- ioptions = 0;
- else
- {
- SCM_ASSERT (SCM_INUMP (options), options, SCM_ARG2, s_waitpid);
- /* Flags are interned in scm_init_posix. */
- ioptions = SCM_INUM (options);
- }
- SCM_SYSCALL (i = waitpid (SCM_INUM (pid), &status, ioptions));
- if (i == -1)
- scm_syserror (s_waitpid);
- return scm_cons (SCM_MAKINUM (0L + i), SCM_MAKINUM (0L + status));
-#else
- scm_sysmissing (s_waitpid);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-
-SCM_PROC (s_getppid, "getppid", 0, 0, 0, scm_getppid);
-
-SCM
-scm_getppid ()
-{
- return SCM_MAKINUM (0L + getppid ());
-}
-
-
-
-SCM_PROC (s_getuid, "getuid", 0, 0, 0, scm_getuid);
-
-SCM
-scm_getuid ()
-{
- return SCM_MAKINUM (0L + getuid ());
-}
-
-
-
-SCM_PROC (s_getgid, "getgid", 0, 0, 0, scm_getgid);
-
-SCM
-scm_getgid ()
-{
- return SCM_MAKINUM (0L + getgid ());
-}
-
-
-
-SCM_PROC (s_geteuid, "geteuid", 0, 0, 0, scm_geteuid);
-
-SCM
-scm_geteuid ()
-{
-#ifdef HAVE_GETEUID
- return SCM_MAKINUM (0L + geteuid ());
-#else
- return SCM_MAKINUM (0L + getuid ());
-#endif
-}
-
-
-
-SCM_PROC (s_getegid, "getegid", 0, 0, 0, scm_getegid);
-
-SCM
-scm_getegid ()
-{
-#ifdef HAVE_GETEUID
- return SCM_MAKINUM (0L + getegid ());
-#else
- return SCM_MAKINUM (0L + getgid ());
-#endif
-}
-
-
-SCM_PROC (s_setuid, "setuid", 1, 0, 0, scm_setuid);
-
-SCM
-scm_setuid (id)
- SCM id;
-{
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setuid);
- if (setuid (SCM_INUM (id)) != 0)
- scm_syserror (s_setuid);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_setgid, "setgid", 1, 0, 0, scm_setgid);
-
-SCM
-scm_setgid (id)
- SCM id;
-{
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setgid);
- if (setgid (SCM_INUM (id)) != 0)
- scm_syserror (s_setgid);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_seteuid, "seteuid", 1, 0, 0, scm_seteuid);
-
-SCM
-scm_seteuid (id)
- SCM id;
-{
- int rv;
-
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_seteuid);
-#ifdef HAVE_SETEUID
- rv = seteuid (SCM_INUM (id));
-#else
- rv = setuid (SCM_INUM (id));
-#endif
- if (rv != 0)
- scm_syserror (s_seteuid);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_setegid, "setegid", 1, 0, 0, scm_setegid);
-
-SCM
-scm_setegid (id)
- SCM id;
-{
- int rv;
-
- SCM_ASSERT (SCM_INUMP (id), id, SCM_ARG1, s_setegid);
-#ifdef HAVE_SETEUID
- rv = setegid (SCM_INUM (id));
-#else
- rv = setgid (SCM_INUM (id));
-#endif
- if (rv != 0)
- scm_syserror (s_setegid);
- return SCM_UNSPECIFIED;
-
-}
-
-SCM_PROC (s_getpgrp, "getpgrp", 0, 0, 0, scm_getpgrp);
-SCM
-scm_getpgrp ()
-{
- int (*fn)();
- fn = (int (*) ()) getpgrp;
- return SCM_MAKINUM (fn (0));
-}
-
-SCM_PROC (s_setpgid, "setpgid", 2, 0, 0, scm_setpgid);
-SCM
-scm_setpgid (pid, pgid)
- SCM pid, pgid;
-{
-#ifdef HAVE_SETPGID
- SCM_ASSERT (SCM_INUMP (pid), pid, SCM_ARG1, s_setpgid);
- SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_setpgid);
- /* FIXME(?): may be known as setpgrp. */
- if (setpgid (SCM_INUM (pid), SCM_INUM (pgid)) != 0)
- scm_syserror (s_setpgid);
- return SCM_UNSPECIFIED;
-#else
- scm_sysmissing (s_setpgid);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_setsid, "setsid", 0, 0, 0, scm_setsid);
-SCM
-scm_setsid ()
-{
-#ifdef HAVE_SETSID
- pid_t sid = setsid ();
- if (sid == -1)
- scm_syserror (s_setsid);
- return SCM_UNSPECIFIED;
-#else
- scm_sysmissing (s_setsid);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_ttyname, "ttyname", 1, 0, 0, scm_ttyname);
-
-SCM
-scm_ttyname (port)
- SCM port;
-{
- char *ans;
- int fd;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPPORTP (port), port, SCM_ARG1, s_ttyname);
- if (scm_tc16_fport != SCM_TYP16 (port))
- return SCM_BOOL_F;
- fd = fileno ((FILE *)SCM_STREAM (port));
- if (fd == -1)
- scm_syserror (s_ttyname);
- SCM_SYSCALL (ans = ttyname (fd));
- if (!ans)
- scm_syserror (s_ttyname);
- /* ans could be overwritten by another call to ttyname */
- return (scm_makfrom0str (ans));
-}
-
-
-SCM_PROC (s_ctermid, "ctermid", 0, 0, 0, scm_ctermid);
-SCM
-scm_ctermid ()
-{
-#ifdef HAVE_CTERMID
- char *result = ctermid (NULL);
- if (*result == '\0')
- scm_syserror (s_ctermid);
- return scm_makfrom0str (result);
-#else
- scm_sysmissing (s_ctermid);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_tcgetpgrp, "tcgetpgrp", 1, 0, 0, scm_tcgetpgrp);
-SCM
-scm_tcgetpgrp (port)
- SCM port;
-{
-#ifdef HAVE_TCGETPGRP
- int fd;
- pid_t pgid;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcgetpgrp);
- fd = fileno ((FILE *)SCM_STREAM (port));
- if (fd == -1 || (pgid = tcgetpgrp (fd)) == -1)
- scm_syserror (s_tcgetpgrp);
- return SCM_MAKINUM (pgid);
-#else
- scm_sysmissing (s_tcgetpgrp);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_tcsetpgrp, "tcsetpgrp", 2, 0, 0, scm_tcsetpgrp);
-SCM
-scm_tcsetpgrp (port, pgid)
- SCM port, pgid;
-{
-#ifdef HAVE_TCSETPGRP
- int fd;
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPFPORTP (port), port, SCM_ARG1, s_tcsetpgrp);
- SCM_ASSERT (SCM_INUMP (pgid), pgid, SCM_ARG2, s_tcsetpgrp);
- fd = fileno ((FILE *)SCM_STREAM (port));
- if (fd == -1 || tcsetpgrp (fd, SCM_INUM (pgid)) == -1)
- scm_syserror (s_tcsetpgrp);
- return SCM_UNSPECIFIED;
-#else
- scm_sysmissing (s_tcsetpgrp);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-/* Copy exec args from an SCM vector into a new C array. */
-
-static char ** scm_convert_exec_args SCM_P ((SCM args));
-
-static char **
-scm_convert_exec_args (args)
- SCM args;
-{
- char **execargv;
- int num_args;
- int i;
- SCM_DEFER_INTS;
- num_args = scm_ilength (args);
- execargv = (char **)
- scm_must_malloc ((num_args + 1) * sizeof (char *), s_ttyname);
- for (i = 0; SCM_NNULLP (args); args = SCM_CDR (args), ++i)
- {
- scm_sizet len;
- char *dst;
- char *src;
- SCM_ASSERT (SCM_NIMP (SCM_CAR (args)) && SCM_ROSTRINGP (SCM_CAR (args)), SCM_CAR (args),
- "wrong type in SCM_ARG", "exec arg");
- len = 1 + SCM_ROLENGTH (SCM_CAR (args));
- dst = (char *) scm_must_malloc ((long) len, s_ttyname);
- src = SCM_ROCHARS (SCM_CAR (args));
- while (len--)
- dst[len] = src[len];
- execargv[i] = dst;
- }
- execargv[i] = 0;
- SCM_ALLOW_INTS;
- return execargv;
-}
-
-SCM_PROC (s_execl, "execl", 0, 0, 1, scm_execl);
-
-SCM
-scm_execl (args)
- SCM args;
-{
- char **execargv;
- SCM filename = SCM_CAR (args);
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_execl);
- if (SCM_SUBSTRP (filename))
- filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
- args = SCM_CDR (args);
- execargv = scm_convert_exec_args (args);
- execv (SCM_ROCHARS (filename), execargv);
- scm_syserror (s_execl);
- /* not reached. */
- return SCM_BOOL_F;
-}
-
-SCM_PROC (s_execlp, "execlp", 0, 0, 1, scm_execlp);
-
-SCM
-scm_execlp (args)
- SCM args;
-{
- char **execargv;
- SCM filename = SCM_CAR (args);
- SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename, SCM_ARG1, s_execlp);
- if (SCM_SUBSTRP (filename))
- filename = scm_makfromstr (SCM_ROCHARS (filename), SCM_ROLENGTH (filename), 0);
- args = SCM_CDR (args);
- execargv = scm_convert_exec_args (args);
- execvp (SCM_ROCHARS (filename), execargv);
- scm_syserror (s_execlp);
- /* not reached. */
- return SCM_BOOL_F;
-}
-
-/* Flushing streams etc., is not done here. */
-SCM_PROC (s_fork, "fork", 0, 0, 0, scm_fork);
-
-SCM
-scm_fork()
-{
- int pid;
- pid = fork ();
- if (pid == -1)
- scm_syserror (s_fork);
- return SCM_MAKINUM (0L+pid);
-}
-
-
-SCM_PROC (s_uname, "uname", 0, 0, 0, scm_uname);
-
-SCM
-scm_uname ()
-{
-#ifdef HAVE_UNAME
- struct utsname buf;
- SCM ans = scm_make_vector(SCM_MAKINUM(5), SCM_UNSPECIFIED, SCM_BOOL_F);
- SCM *ve = SCM_VELTS (ans);
- if (uname (&buf))
- return SCM_MAKINUM (errno);
- ve[0] = scm_makfrom0str (buf.sysname);
- ve[1] = scm_makfrom0str (buf.nodename);
- ve[2] = scm_makfrom0str (buf.release);
- ve[3] = scm_makfrom0str (buf.version);
- ve[4] = scm_makfrom0str (buf.machine);
-/*
- a linux special?
- ve[5] = scm_makfrom0str (buf.domainname);
-*/
- return ans;
-#else
- scm_sysmissing (s_uname);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_environ, "environ", 0, 1, 0, scm_environ);
-
-SCM
-scm_environ (env)
- SCM env;
-{
- if (SCM_UNBNDP (env))
- return scm_makfromstrs (-1, environ);
- else
- {
- int num_strings;
- char **new_environ;
- int i = 0;
- SCM_ASSERT (SCM_NULLP (env) || (SCM_NIMP (env) && SCM_CONSP (env)),
- env, SCM_ARG1, s_environ);
- num_strings = scm_ilength (env);
- new_environ = (char **) scm_must_malloc ((num_strings + 1)
- * sizeof (char *),
- s_environ);
- while (SCM_NNULLP (env))
- {
- int len;
- char *src;
- SCM_ASSERT (SCM_NIMP (SCM_CAR (env)) && SCM_ROSTRINGP (SCM_CAR (env)), env, SCM_ARG1,
- s_environ);
- len = 1 + SCM_ROLENGTH (SCM_CAR (env));
- new_environ[i] = scm_must_malloc ((long) len, s_environ);
- src = SCM_ROCHARS (SCM_CAR (env));
- while (len--)
- new_environ[i][len] = src[len];
- env = SCM_CDR (env);
- i++;
- }
- new_environ[i] = 0;
- /* Free the old environment, except when called for the first
- * time.
- */
- {
- char **ep;
- static int first = 1;
- if (!first)
- {
- for (ep = environ; *ep != NULL; ep++)
- scm_must_free (*ep);
- scm_must_free ((char *) environ);
- }
- first = 0;
- }
- environ = new_environ;
- return SCM_UNSPECIFIED;
- }
-}
-
-#ifdef L_tmpnam
-
-SCM_PROC (s_tmpnam, "tmpnam", 0, 0, 0, scm_tmpnam);
-
-SCM scm_tmpnam()
-{
- char name[L_tmpnam];
- SCM_SYSCALL (tmpnam (name););
- return scm_makfrom0str (name);
-}
-#endif
-
-SCM_PROC (s_open_pipe, "open-pipe", 2, 0, 0, scm_open_pipe);
-
-SCM
-scm_open_pipe (pipestr, modes)
- SCM pipestr;
- SCM modes;
-{
- FILE *f;
- register SCM z;
- struct scm_port_table * pt;
-
- SCM_ASSERT (SCM_NIMP (pipestr) && SCM_ROSTRINGP (pipestr), pipestr, SCM_ARG1, s_open_pipe);
- if (SCM_SUBSTRP (pipestr))
- pipestr = scm_makfromstr (SCM_ROCHARS (pipestr), SCM_ROLENGTH (pipestr), 0);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_ROSTRINGP (modes), modes, SCM_ARG2, s_open_pipe);
- if (SCM_SUBSTRP (modes))
- modes = scm_makfromstr (SCM_ROCHARS (modes), SCM_ROLENGTH (modes), 0);
- SCM_NEWCELL (z);
- SCM_DEFER_INTS;
- scm_ignore_signals ();
- SCM_SYSCALL (f = popen (SCM_ROCHARS (pipestr), SCM_ROCHARS (modes)));
- scm_unignore_signals ();
- if (!f)
- scm_syserror (s_open_pipe);
- pt = scm_add_to_port_table (z);
- SCM_SETPTAB_ENTRY (z, pt);
- SCM_SETCAR (z, scm_tc16_pipe | SCM_OPN
- | (strchr (SCM_ROCHARS (modes), 'r') ? SCM_RDNG : SCM_WRTNG));
- SCM_SETSTREAM (z, (SCM)f);
- SCM_ALLOW_INTS;
- return z;
-}
-
-
-SCM_PROC (s_open_input_pipe, "open-input-pipe", 1, 0, 0, scm_open_input_pipe);
-
-SCM
-scm_open_input_pipe(pipestr)
- SCM pipestr;
-{
- return scm_open_pipe(pipestr, scm_makfromstr("r", (sizeof "r")-1, 0));
-}
-
-SCM_PROC (s_open_output_pipe, "open-output-pipe", 1, 0, 0, scm_open_output_pipe);
-
-SCM
-scm_open_output_pipe(pipestr)
- SCM pipestr;
-{
- return scm_open_pipe(pipestr, scm_makfromstr("w", (sizeof "w")-1, 0));
-}
-
-
-SCM_PROC (s_utime, "utime", 1, 2, 0, scm_utime);
-
-SCM
-scm_utime (pathname, actime, modtime)
- SCM pathname;
- SCM actime;
- SCM modtime;
-{
- int rv;
- struct utimbuf utm_tmp;
-
- SCM_ASSERT (SCM_NIMP (pathname) && SCM_STRINGP (pathname), pathname, SCM_ARG1, s_utime);
-
- if (SCM_UNBNDP (actime))
- SCM_SYSCALL (time (&utm_tmp.actime));
- else
- utm_tmp.actime = scm_num2ulong (actime, (char *) SCM_ARG2, s_utime);
-
- if (SCM_UNBNDP (modtime))
- SCM_SYSCALL (time (&utm_tmp.modtime));
- else
- utm_tmp.modtime = scm_num2ulong (modtime, (char *) SCM_ARG3, s_utime);
-
- SCM_SYSCALL (rv = utime (SCM_CHARS (pathname), &utm_tmp));
- if (rv != 0)
- scm_syserror (s_utime);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_access, "access?", 2, 0, 0, scm_access);
-
-SCM
-scm_access (path, how)
- SCM path;
- SCM how;
-{
- int rv;
-
- SCM_ASSERT (SCM_NIMP (path) && SCM_ROSTRINGP (path), path, SCM_ARG1, s_access);
- if (SCM_SUBSTRP (path))
- path = scm_makfromstr (SCM_ROCHARS (path), SCM_ROLENGTH (path), 0);
- SCM_ASSERT (SCM_INUMP (how), how, SCM_ARG2, s_access);
- rv = access (SCM_ROCHARS (path), SCM_INUM (how));
- return rv ? SCM_BOOL_F : SCM_BOOL_T;
-}
-
-SCM_PROC (s_getpid, "getpid", 0, 0, 0, scm_getpid);
-
-SCM
-scm_getpid ()
-{
- return SCM_MAKINUM ((unsigned long) getpid ());
-}
-
-SCM_PROC (s_putenv, "putenv", 1, 0, 0, scm_putenv);
-
-SCM
-scm_putenv (str)
- SCM str;
-{
-#ifdef HAVE_PUTENV
- int rv;
-
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_putenv);
- rv = putenv (SCM_CHARS (str));
- if (rv < 0)
- scm_syserror (s_putenv);
- return SCM_UNSPECIFIED;
-#else
- scm_sysmissing (s_putenv);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_read_line, "read-line", 0, 2, 0, scm_read_line);
-
-SCM
-scm_read_line (port, include_terminator)
- SCM port;
- SCM include_terminator;
-{
- register int c;
- register int j = 0;
- scm_sizet len = 30;
- SCM tok_buf;
- register char *p;
- int include;
-
- tok_buf = scm_makstr ((long) len, 0);
- p = SCM_CHARS (tok_buf);
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG1, s_read_line);
-
- if (SCM_UNBNDP (include_terminator))
- include = 0;
- else
- include = SCM_NFALSEP (include_terminator);
-
- if (EOF == (c = scm_gen_getc (port)))
- return SCM_EOF_VAL;
- while (1)
- {
- switch (c)
- {
- case SCM_LINE_INCREMENTORS:
- if (j >= len)
- {
- p = scm_grow_tok_buf (&tok_buf);
- len = SCM_LENGTH (tok_buf);
- }
- p[j++] = c;
- /* fallthrough */
- case EOF:
- if (len == j)
- return tok_buf;
- return scm_vector_set_length_x (tok_buf, (SCM) SCM_MAKINUM (j));
-
- default:
- if (j >= len)
- {
- p = scm_grow_tok_buf (&tok_buf);
- len = SCM_LENGTH (tok_buf);
- }
- p[j++] = c;
- c = scm_gen_getc (port);
- break;
- }
- }
-}
-
-SCM_PROC (s_read_line_x, "read-line!", 1, 1, 0, scm_read_line_x);
-
-SCM
-scm_read_line_x (str, port)
- SCM str;
- SCM port;
-{
- register int c;
- register int j = 0;
- register char *p;
- scm_sizet len;
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_read_line_x);
- p = SCM_CHARS (str);
- len = SCM_LENGTH (str);
- if SCM_UNBNDP
- (port) port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port), port, SCM_ARG2, s_read_line_x);
- c = scm_gen_getc (port);
- if (EOF == c)
- return SCM_EOF_VAL;
- while (1)
- {
- switch (c)
- {
- case SCM_LINE_INCREMENTORS:
- case EOF:
- return SCM_MAKINUM (j);
- default:
- if (j >= len)
- {
- scm_gen_ungetc (c, port);
- return SCM_BOOL_F;
- }
- p[j++] = c;
- c = scm_gen_getc (port);
- }
- }
-}
-
-SCM_PROC (s_write_line, "write-line", 1, 1, 0, scm_write_line);
-
-SCM
-scm_write_line (obj, port)
- SCM obj;
- SCM port;
-{
- scm_display (obj, port);
- return scm_newline (port);
-}
-
-SCM_PROC (s_setlocale, "setlocale", 1, 1, 0, scm_setlocale);
-
-SCM
-scm_setlocale (category, locale)
- SCM category;
- SCM locale;
-{
-#ifdef HAVE_SETLOCALE
- char *clocale;
- char *rv;
-
- SCM_ASSERT (SCM_INUMP (category), category, SCM_ARG1, s_setlocale);
- if (SCM_UNBNDP (locale))
- {
- clocale = NULL;
- }
- else
- {
- SCM_ASSERT (SCM_NIMP (locale) && SCM_STRINGP (locale), locale, SCM_ARG2, s_setlocale);
- clocale = SCM_CHARS (locale);
- }
-
- rv = setlocale (SCM_INUM (category), clocale);
- if (rv == NULL)
- scm_syserror (s_setlocale);
- return scm_makfrom0str (rv);
-#else
- scm_sysmissing (s_setlocale);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime);
-
-SCM
-scm_strftime (format, stime)
- SCM format;
- SCM stime;
-{
- struct tm t;
-
- char *tbuf;
- int n;
- int size = 50;
- char *fmt;
- int len;
-
- SCM_ASSERT (SCM_NIMP (format) && SCM_STRINGP (format), format, SCM_ARG1, s_strftime);
- SCM_ASSERT (SCM_NIMP (stime) && SCM_VECTORP (stime) && scm_obj_length (stime) == 9,
- stime, SCM_ARG2, s_strftime);
-
- fmt = SCM_ROCHARS (format);
- len = SCM_ROLENGTH (format);
-
-#define tm_deref scm_num2long (SCM_VELTS (stime)[n++], (char *)SCM_ARG2, s_strftime)
- n = 0;
- t.tm_sec = tm_deref;
- t.tm_min = tm_deref;
- t.tm_hour = tm_deref;
- t.tm_mday = tm_deref;
- t.tm_mon = tm_deref;
- t.tm_year = tm_deref;
- /* not used by mktime.
- t.tm_wday = tm_deref;
- t.tm_yday = tm_deref; */
- t.tm_isdst = tm_deref;
-#undef tm_deref
-
- /* fill in missing fields and set the timezone. */
- mktime (&t);
-
- tbuf = scm_must_malloc (size, s_strftime);
- while ((len = strftime (tbuf, size, fmt, &t)) == size)
- {
- scm_must_free (tbuf);
- size *= 2;
- tbuf = scm_must_malloc (size, s_strftime);
- }
- return scm_makfromstr (tbuf, len, 0);
-}
-
-SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime);
-
-SCM
-scm_strptime (format, string)
- SCM format;
- SCM string;
-{
-#ifdef HAVE_STRPTIME
- SCM stime;
- struct tm t;
-
- char *fmt, *str, *rest;
- int n;
-
- SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, s_strptime);
- if (SCM_SUBSTRP (format))
- format = scm_makfromstr (SCM_ROCHARS (format), SCM_ROLENGTH (format), 0);
- SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2, s_strptime);
- if (SCM_SUBSTRP (string))
- string = scm_makfromstr (SCM_ROCHARS (string), SCM_ROLENGTH (string), 0);
-
- fmt = SCM_CHARS (format);
- str = SCM_CHARS (string);
-
- /* initialize the struct tm */
-#define tm_init(field) t.field = 0
- tm_init (tm_sec);
- tm_init (tm_min);
- tm_init (tm_hour);
- tm_init (tm_mday);
- tm_init (tm_mon);
- tm_init (tm_year);
- tm_init (tm_wday);
- tm_init (tm_yday);
- tm_init (tm_isdst);
-#undef tm_init
-
- SCM_DEFER_INTS;
- rest = strptime (str, fmt, &t);
- SCM_ALLOW_INTS;
-
- if (rest == NULL)
- scm_syserror (s_strptime);
-
- stime = scm_make_vector (SCM_MAKINUM (9), scm_long2num (0), SCM_UNDEFINED);
-
-#define stime_set(val) scm_vector_set_x (stime, SCM_MAKINUM (n++), scm_long2num (t.val));
- n = 0;
- stime_set (tm_sec);
- stime_set (tm_min);
- stime_set (tm_hour);
- stime_set (tm_mday);
- stime_set (tm_mon);
- stime_set (tm_year);
- stime_set (tm_wday);
- stime_set (tm_yday);
- stime_set (tm_isdst);
-#undef stime_set
-
- return scm_cons (stime, scm_makfrom0str (rest));
-#else
- scm_sysmissing (s_strptime);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-SCM_PROC (s_mknod, "mknod", 3, 0, 0, scm_mknod);
-
-SCM
-scm_mknod(path, mode, dev)
- SCM path;
- SCM mode;
- SCM dev;
-{
-#ifdef HAVE_MKNOD
- int val;
- SCM_ASSERT(SCM_NIMP(path) && SCM_STRINGP(path), path, SCM_ARG1, s_mknod);
- SCM_ASSERT(SCM_INUMP(mode), mode, SCM_ARG2, s_mknod);
- SCM_ASSERT(SCM_INUMP(dev), dev, SCM_ARG3, s_mknod);
- SCM_SYSCALL(val = mknod(SCM_CHARS(path), SCM_INUM(mode), SCM_INUM(dev)));
- if (val != 0)
- scm_syserror (s_mknod);
- return SCM_UNSPECIFIED;
-#else
- scm_sysmissing (s_mknod);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-SCM_PROC (s_nice, "nice", 1, 0, 0, scm_nice);
-
-SCM
-scm_nice(incr)
- SCM incr;
-{
-#ifdef HAVE_NICE
- SCM_ASSERT(SCM_INUMP(incr), incr, SCM_ARG1, s_nice);
- if (nice(SCM_INUM(incr)) != 0)
- scm_syserror (s_nice);
- return SCM_UNSPECIFIED;
-#else
- scm_sysmissing (s_nice);
- /* not reached. */
- return SCM_BOOL_F;
-#endif
-}
-
-
-SCM_PROC (s_sync, "sync", 0, 0, 0, scm_sync);
-
-SCM
-scm_sync()
-{
-#ifdef HAVE_SYNC
- sync();
-#else
- scm_sysmissing (s_sync);
- /* not reached. */
-#endif
- return SCM_BOOL_F;
-}
-
-
-
-
-void
-scm_init_posix ()
-{
- scm_add_feature ("posix");
-#ifdef HAVE_GETEUID
- scm_add_feature ("EIDs");
-#endif
-#ifdef WAIT_ANY
- scm_sysintern ("WAIT_ANY", SCM_MAKINUM (WAIT_ANY));
-#endif
-#ifdef WAIT_MYPGRP
- scm_sysintern ("WAIT_MYPGRP", SCM_MAKINUM (WAIT_MYPGRP));
-#endif
-#ifdef WNOHANG
- scm_sysintern ("WNOHANG", SCM_MAKINUM (WNOHANG));
-#endif
-#ifdef WUNTRACED
- scm_sysintern ("WUNTRACED", SCM_MAKINUM (WUNTRACED));
-#endif
-
-#ifdef EINTR
- scm_sysintern ("EINTR", SCM_MAKINUM (EINTR));
-#endif
-
-#ifdef SIGHUP
- scm_sysintern ("SIGHUP", SCM_MAKINUM (SIGHUP));
-#endif
-#ifdef SIGINT
- scm_sysintern ("SIGINT", SCM_MAKINUM (SIGINT));
-#endif
-#ifdef SIGQUIT
- scm_sysintern ("SIGQUIT", SCM_MAKINUM (SIGQUIT));
-#endif
-#ifdef SIGILL
- scm_sysintern ("SIGILL", SCM_MAKINUM (SIGILL));
-#endif
-#ifdef SIGTRAP
- scm_sysintern ("SIGTRAP", SCM_MAKINUM (SIGTRAP));
-#endif
-#ifdef SIGABRT
- scm_sysintern ("SIGABRT", SCM_MAKINUM (SIGABRT));
-#endif
-#ifdef SIGIOT
- scm_sysintern ("SIGIOT", SCM_MAKINUM (SIGIOT));
-#endif
-#ifdef SIGBUS
- scm_sysintern ("SIGBUS", SCM_MAKINUM (SIGBUS));
-#endif
-#ifdef SIGFPE
- scm_sysintern ("SIGFPE", SCM_MAKINUM (SIGFPE));
-#endif
-#ifdef SIGKILL
- scm_sysintern ("SIGKILL", SCM_MAKINUM (SIGKILL));
-#endif
-#ifdef SIGUSR1
- scm_sysintern ("SIGUSR1", SCM_MAKINUM (SIGUSR1));
-#endif
-#ifdef SIGSEGV
- scm_sysintern ("SIGSEGV", SCM_MAKINUM (SIGSEGV));
-#endif
-#ifdef SIGUSR2
- scm_sysintern ("SIGUSR2", SCM_MAKINUM (SIGUSR2));
-#endif
-#ifdef SIGPIPE
- scm_sysintern ("SIGPIPE", SCM_MAKINUM (SIGPIPE));
-#endif
-#ifdef SIGALRM
- scm_sysintern ("SIGALRM", SCM_MAKINUM (SIGALRM));
-#endif
-#ifdef SIGTERM
- scm_sysintern ("SIGTERM", SCM_MAKINUM (SIGTERM));
-#endif
-#ifdef SIGSTKFLT
- scm_sysintern ("SIGSTKFLT", SCM_MAKINUM (SIGSTKFLT));
-#endif
-#ifdef SIGCHLD
- scm_sysintern ("SIGCHLD", SCM_MAKINUM (SIGCHLD));
-#endif
-#ifdef SIGCONT
- scm_sysintern ("SIGCONT", SCM_MAKINUM (SIGCONT));
-#endif
-#ifdef SIGSTOP
- scm_sysintern ("SIGSTOP", SCM_MAKINUM (SIGSTOP));
-#endif
-#ifdef SIGTSTP
- scm_sysintern ("SIGTSTP", SCM_MAKINUM (SIGTSTP));
-#endif
-#ifdef SIGTTIN
- scm_sysintern ("SIGTTIN", SCM_MAKINUM (SIGTTIN));
-#endif
-#ifdef SIGTTOU
- scm_sysintern ("SIGTTOU", SCM_MAKINUM (SIGTTOU));
-#endif
-#ifdef SIGIO
- scm_sysintern ("SIGIO", SCM_MAKINUM (SIGIO));
-#endif
-#ifdef SIGPOLL
- scm_sysintern ("SIGPOLL", SCM_MAKINUM (SIGPOLL));
-#endif
-#ifdef SIGURG
- scm_sysintern ("SIGURG", SCM_MAKINUM (SIGURG));
-#endif
-#ifdef SIGXCPU
- scm_sysintern ("SIGXCPU", SCM_MAKINUM (SIGXCPU));
-#endif
-#ifdef SIGXFSZ
- scm_sysintern ("SIGXFSZ", SCM_MAKINUM (SIGXFSZ));
-#endif
-#ifdef SIGVTALRM
- scm_sysintern ("SIGVTALRM", SCM_MAKINUM (SIGVTALRM));
-#endif
-#ifdef SIGPROF
- scm_sysintern ("SIGPROF", SCM_MAKINUM (SIGPROF));
-#endif
-#ifdef SIGWINCH
- scm_sysintern ("SIGWINCH", SCM_MAKINUM (SIGWINCH));
-#endif
-#ifdef SIGLOST
- scm_sysintern ("SIGLOST", SCM_MAKINUM (SIGLOST));
-#endif
-#ifdef SIGPWR
- scm_sysintern ("SIGPWR", SCM_MAKINUM (SIGPWR));
-#endif
- /* access() symbols. */
- scm_sysintern ("R_OK", SCM_MAKINUM (R_OK));
- scm_sysintern ("W_OK", SCM_MAKINUM (W_OK));
- scm_sysintern ("X_OK", SCM_MAKINUM (X_OK));
- scm_sysintern ("F_OK", SCM_MAKINUM (F_OK));
-
-#ifdef LC_COLLATE
- scm_sysintern ("LC_COLLATE", SCM_MAKINUM (LC_COLLATE));
-#endif
-#ifdef LC_CTYPE
- scm_sysintern ("LC_CTYPE", SCM_MAKINUM (LC_CTYPE));
-#endif
-#ifdef LC_MONETARY
- scm_sysintern ("LC_MONETARY", SCM_MAKINUM (LC_MONETARY));
-#endif
-#ifdef LC_NUMERIC
- scm_sysintern ("LC_NUMERIC", SCM_MAKINUM (LC_NUMERIC));
-#endif
-#ifdef LC_TIME
- scm_sysintern ("LC_TIME", SCM_MAKINUM (LC_TIME));
-#endif
-#ifdef LC_MESSAGES
- scm_sysintern ("LC_MESSAGES", SCM_MAKINUM (LC_MESSAGES));
-#endif
-#ifdef LC_ALL
- scm_sysintern ("LC_ALL", SCM_MAKINUM (LC_ALL));
-#endif
-#include "posix.x"
-}
diff --git a/libguile/posix.h b/libguile/posix.h
deleted file mode 100644
index 1dd9eb52d..000000000
--- a/libguile/posix.h
+++ /dev/null
@@ -1,101 +0,0 @@
-/* classes: h_files */
-
-#ifndef POSIXH
-#define POSIXH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-
-
-
-extern SCM scm_tcsetpgrp SCM_P ((SCM port, SCM pgid));
-extern SCM scm_tcgetpgrp SCM_P ((SCM port));
-extern SCM scm_ctermid SCM_P ((void));
-extern SCM scm_setsid SCM_P ((void));
-extern SCM scm_setpgid SCM_P ((SCM pid, SCM pgid));
-extern SCM scm_pipe SCM_P ((void));
-extern SCM scm_getgroups SCM_P ((void));
-extern SCM scm_getpgrp SCM_P ((void));
-extern SCM scm_getpwuid SCM_P ((SCM user));
-extern SCM scm_setpwent SCM_P ((SCM arg));
-extern SCM scm_getgrgid SCM_P ((SCM name));
-extern SCM scm_setgrent SCM_P ((SCM arg));
-extern SCM scm_kill SCM_P ((SCM pid, SCM sig));
-extern SCM scm_waitpid SCM_P ((SCM pid, SCM options));
-extern SCM scm_getppid SCM_P ((void));
-extern SCM scm_getuid SCM_P ((void));
-extern SCM scm_getgid SCM_P ((void));
-extern SCM scm_geteuid SCM_P ((void));
-extern SCM scm_getegid SCM_P ((void));
-extern SCM scm_setuid SCM_P ((SCM id));
-extern SCM scm_setgid SCM_P ((SCM id));
-extern SCM scm_seteuid SCM_P ((SCM id));
-extern SCM scm_setegid SCM_P ((SCM id));
-extern SCM scm_ttyname SCM_P ((SCM port));
-extern SCM scm_execl SCM_P ((SCM args));
-extern SCM scm_execlp SCM_P ((SCM args));
-extern SCM scm_fork SCM_P ((void));
-extern SCM scm_uname SCM_P ((void));
-extern SCM scm_environ SCM_P ((SCM env));
-extern SCM scm_open_pipe SCM_P ((SCM pipestr, SCM modes));
-extern SCM scm_open_input_pipe SCM_P ((SCM pipestr));
-extern SCM scm_open_output_pipe SCM_P ((SCM pipestr));
-extern SCM scm_utime SCM_P ((SCM pathname, SCM actime, SCM modtime));
-extern SCM scm_access SCM_P ((SCM path, SCM how));
-extern SCM scm_getpid SCM_P ((void));
-extern SCM scm_putenv SCM_P ((SCM str));
-extern SCM scm_read_line SCM_P ((SCM port, SCM include_terminator));
-extern SCM scm_read_line_x SCM_P ((SCM str, SCM port));
-extern SCM scm_write_line SCM_P ((SCM obj, SCM port));
-extern SCM scm_setlocale SCM_P ((SCM category, SCM locale));
-extern SCM scm_strftime SCM_P ((SCM format, SCM stime));
-extern SCM scm_strptime SCM_P ((SCM format, SCM string));
-extern SCM scm_mknod SCM_P ((SCM path, SCM mode, SCM dev));
-extern SCM scm_nice SCM_P ((SCM incr));
-extern SCM scm_sync SCM_P ((void));
-extern void scm_init_posix SCM_P ((void));
-
-#endif /* POSIXH */
diff --git a/libguile/print.c b/libguile/print.c
deleted file mode 100644
index adc70482c..000000000
--- a/libguile/print.c
+++ /dev/null
@@ -1,860 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-#include "genio.h"
-#include "mbstrings.h"
-#include "smob.h"
-#include "eval.h"
-#include "procprop.h"
-#include "read.h"
-#include "weaks.h"
-#include "unif.h"
-#include "alist.h"
-#include "struct.h"
-
-#include "print.h"
-
-
-/* {Names of immediate symbols}
- *
- * This table must agree with the declarations in scm.h: {Immediate Symbols}.
- */
-
-char *scm_isymnames[] =
-{
- /* This table must agree with the declarations */
- "#@and",
- "#@begin",
- "#@case",
- "#@cond",
- "#@do",
- "#@if",
- "#@lambda",
- "#@let",
- "#@let*",
- "#@letrec",
- "#@or",
- "#@quote",
- "#@set!",
- "#@define",
-#if 0
- "#@literal-variable-ref",
- "#@literal-variable-set!",
-#endif
- "#@apply",
- "#@call-with-current-continuation",
-
- /* user visible ISYMS */
- /* other keywords */
- /* Flags */
-
- "#f",
- "#t",
- "#<undefined>",
- "#<eof>",
- "()",
- "#<unspecified>"
-};
-
-scm_option scm_print_opts[] = {
- { SCM_OPTION_SCM, "closure-hook", SCM_BOOL_F,
- "Hook for printing closures." },
- { SCM_OPTION_BOOLEAN, "source", 0,
- "Print closures with source." }
-};
-
-SCM_PROC (s_print_options, "print-options-interface", 0, 1, 0, scm_print_options);
-
-SCM
-scm_print_options (setting)
- SCM setting;
-{
- SCM ans = scm_options (setting,
- scm_print_opts,
- SCM_N_PRINT_OPTIONS,
- s_print_options);
- return ans;
-}
-
-
-/* {Printing of Scheme Objects}
- */
-
-/* Detection of circular references.
- *
- * Due to other constraints in the implementation, this code has bad
- * time complexity (O (depth * N)), The printer code will be
- * completely rewritten before next release of Guile. The new code
- * will be O(N).
- */
-#define PUSH_REF(pstate, obj) \
-{ \
- pstate->ref_stack[pstate->top++] = (obj); \
- if (pstate->top == pstate->ceiling) \
- grow_ref_stack (pstate); \
-}
-
-#define ENTER_NESTED_DATA(pstate, obj, label) \
-{ \
- register int i; \
- for (i = 0; i < pstate->top; ++i) \
- if (pstate->ref_stack[i] == (obj)) \
- goto label; \
- if (pstate->fancyp) \
- { \
- if (pstate->top - pstate->list_offset >= pstate->level) \
- { \
- scm_gen_putc ('#', port); \
- return; \
- } \
- } \
- PUSH_REF(pstate, obj); \
-} \
-
-#define EXIT_NESTED_DATA(pstate) { --pstate->top; }
-
-static SCM print_state_pool;
-
-#if 1 /* Used for debugging purposes */
-SCM_PROC(s_current_pstate, "current-pstate", 0, 0, 0, scm_current_pstate);
-
-SCM
-scm_current_pstate ()
-{
- return SCM_CADR (print_state_pool);
-}
-#endif
-
-#define PSTATE_SIZE 50L
-
-static SCM make_print_state SCM_P ((void));
-
-static SCM
-make_print_state ()
-{
- SCM print_state = scm_make_struct (SCM_CAR (print_state_pool), /* pstate type */
- SCM_INUM0,
- SCM_EOL);
- scm_print_state *pstate = SCM_PRINT_STATE (print_state);
- pstate->ref_vect = scm_make_vector (SCM_MAKINUM (PSTATE_SIZE),
- SCM_UNDEFINED,
- SCM_UNDEFINED);
- pstate->ref_stack = SCM_VELTS (pstate->ref_vect);
- pstate->ceiling = SCM_LENGTH (pstate->ref_vect);
- return print_state;
-}
-
-SCM
-scm_make_print_state ()
-{
- SCM answer = 0;
-
- /* First try to allocate a print state from the pool */
- SCM_DEFER_INTS;
- if (SCM_NNULLP (SCM_CDR (print_state_pool)))
- {
- answer = SCM_CADR (print_state_pool);
- SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
- }
- SCM_ALLOW_INTS;
-
- return answer ? answer : make_print_state ();
-}
-
-void
-scm_free_print_state (print_state)
- SCM print_state;
-{
- SCM handle;
- scm_print_state *pstate = SCM_PRINT_STATE (print_state);
- /* Cleanup before returning print state to pool.
- * It is better to do it here. Doing it in scm_prin1
- * would cost more since that function is called much more
- * often.
- */
- pstate->fancyp = 0;
- SCM_NEWCELL (handle);
- SCM_DEFER_INTS;
- SCM_SETCAR (handle, print_state);
- SCM_SETCDR (handle, SCM_CDR (print_state_pool));
- SCM_SETCDR (print_state_pool, handle);
- SCM_ALLOW_INTS;
-}
-
-static void grow_ref_stack SCM_P ((scm_print_state *pstate));
-
-static void
-grow_ref_stack (pstate)
- scm_print_state *pstate;
-{
- int new_size = 2 * pstate->ceiling;
- scm_vector_set_length_x (pstate->ref_vect, SCM_MAKINUM (new_size));
- pstate->ref_stack = SCM_VELTS (pstate->ref_vect);
- pstate->ceiling = new_size;
-}
-
-
-static void print_circref SCM_P ((SCM port, scm_print_state *pstate, SCM ref));
-
-static void
-print_circref (port, pstate, ref)
- SCM port;
- scm_print_state *pstate;
- SCM ref;
-{
- register int i;
- int self = pstate->top - 1;
- i = pstate->top - 1;
- if (SCM_CONSP (pstate->ref_stack[i]))
- {
- while (i > 0)
- {
- if (SCM_NCONSP (pstate->ref_stack[i - 1])
- || SCM_CDR (pstate->ref_stack[i - 1]) != pstate->ref_stack[i])
- break;
- --i;
- }
- self = i;
- }
- for (i = pstate->top - 1; 1; --i)
- if (pstate->ref_stack[i] == ref)
- break;
- scm_gen_putc ('#', port);
- scm_intprint (i - self, 10, port);
- scm_gen_putc ('#', port);
-}
-
-/* Print generally. Handles both write and display according to PSTATE.
- */
-
-
-void
-scm_iprin1 (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- register long i;
-taloop:
- switch (7 & (int) exp)
- {
- case 2:
- case 6:
- scm_intprint (SCM_INUM (exp), 10, port);
- break;
- case 4:
- if (SCM_ICHRP (exp))
- {
- i = SCM_ICHR (exp);
- scm_put_wchar (i, port, SCM_WRITINGP (pstate));
-
- }
- else if (SCM_IFLAGP (exp)
- && (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
- scm_gen_puts (scm_regular_string, SCM_ISYMCHARS (exp), port);
- else if (SCM_ILOCP (exp))
- {
- scm_gen_puts (scm_regular_string, "#@", port);
- scm_intprint ((long) SCM_IFRAME (exp), 10, port);
- scm_gen_putc (SCM_ICDRP (exp) ? '-' : '+', port);
- scm_intprint ((long) SCM_IDIST (exp), 10, port);
- }
- else
- goto idef;
- break;
- case 1:
- /* gloc */
- scm_gen_puts (scm_regular_string, "#@", port);
- exp = SCM_CAR (exp - 1);
- goto taloop;
- default:
- idef:
- scm_ipruk ("immediate", exp, port);
- break;
- case 0:
- switch (SCM_TYP7 (exp))
- {
- case scm_tcs_cons_gloc:
-
- if (SCM_CDR (SCM_CAR (exp) - 1L) == 0)
- {
- scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port);
- scm_intprint(exp, 16, port);
- scm_gen_putc ('>', port);
- break;
- }
-
- case scm_tcs_cons_imcar:
- case scm_tcs_cons_nimcar:
- ENTER_NESTED_DATA (pstate, exp, circref);
- scm_iprlist ("(", exp, ')', port, pstate);
- EXIT_NESTED_DATA (pstate);
- break;
- circref:
- print_circref (port, pstate, exp);
- break;
- case scm_tcs_closures:
- if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)))
- {
- SCM ans = scm_cons2 (exp, port,
- scm_cons (SCM_WRITINGP (pstate)
- ? SCM_BOOL_T
- : SCM_BOOL_F,
- SCM_EOL));
- ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL);
- }
- else
- {
- SCM name, code;
- name = scm_procedure_property (exp, scm_i_name);
- code = SCM_CODE (exp);
- scm_gen_puts (scm_regular_string, "#<procedure ", port);
- if (SCM_NIMP (name) && SCM_ROSTRINGP (name))
- {
- scm_gen_puts (scm_regular_string, SCM_ROCHARS (name), port);
- scm_gen_putc (' ', port);
- }
- scm_iprin1 (SCM_CAR (code), port, pstate);
- if (SCM_PRINT_SOURCE_P)
- {
- code = scm_unmemocopy (SCM_CDR (code),
- SCM_EXTEND_ENV (SCM_CAR (code),
- SCM_EOL,
- SCM_ENV (exp)));
- ENTER_NESTED_DATA (pstate, exp, circref);
- scm_iprlist (" ", code, '>', port, pstate);
- EXIT_NESTED_DATA (pstate);
- }
- else
- scm_gen_putc ('>', port);
- }
- break;
- case scm_tc7_mb_string:
- case scm_tc7_mb_substring:
- scm_print_mb_string (exp, port, SCM_WRITINGP (pstate));
- break;
- case scm_tc7_substring:
- case scm_tc7_string:
- if (SCM_WRITINGP (pstate))
- {
- scm_gen_putc ('"', port);
- for (i = 0; i < SCM_ROLENGTH (exp); ++i)
- switch (SCM_ROCHARS (exp)[i])
- {
- case '"':
- case '\\':
- scm_gen_putc ('\\', port);
- default:
- scm_gen_putc (SCM_ROCHARS (exp)[i], port);
- }
- scm_gen_putc ('"', port);
- break;
- }
- else
- scm_gen_write (scm_regular_string, SCM_ROCHARS (exp),
- (scm_sizet) SCM_ROLENGTH (exp),
- port);
- break;
- case scm_tcs_symbols:
- if (SCM_MB_STRINGP (exp))
- {
- scm_print_mb_symbol (exp, port);
- break;
- }
- else
- {
- int pos;
- int end;
- int len;
- char * str;
- int weird;
- int maybe_weird;
- int mw_pos = 0;
-
- len = SCM_LENGTH (exp);
- str = SCM_CHARS (exp);
- scm_remember (&exp);
- pos = 0;
- weird = 0;
- maybe_weird = 0;
-
- if (len == 0)
- scm_gen_write (scm_regular_string, "#{}#", 4, port);
-
- for (end = pos; end < len; ++end)
- switch (str[end])
- {
-#ifdef BRACKETS_AS_PARENS
- case '[':
- case ']':
-#endif
- case '(':
- case ')':
- case '"':
- case ';':
- case SCM_WHITE_SPACES:
- case SCM_LINE_INCREMENTORS:
- weird_handler:
- if (maybe_weird)
- {
- end = mw_pos;
- maybe_weird = 0;
- }
- if (!weird)
- {
- scm_gen_write (scm_regular_string, "#{", 2, port);
- weird = 1;
- }
- if (pos < end)
- {
- scm_gen_write (scm_regular_string, str + pos, end - pos, port);
- }
- {
- char buf[2];
- buf[0] = '\\';
- buf[1] = str[end];
- scm_gen_write (scm_regular_string, buf, 2, port);
- }
- pos = end + 1;
- break;
- case '\\':
- if (weird)
- goto weird_handler;
- if (!maybe_weird)
- {
- maybe_weird = 1;
- mw_pos = pos;
- }
- break;
- case '}':
- case '#':
- if (weird)
- goto weird_handler;
- break;
- default:
- break;
- }
- if (pos < end)
- scm_gen_write (scm_regular_string, str + pos, end - pos, port);
- if (weird)
- scm_gen_write (scm_regular_string, "}#", 2, port);
- break;
- }
- case scm_tc7_wvect:
- ENTER_NESTED_DATA (pstate, exp, circref);
- if (SCM_IS_WHVEC (exp))
- scm_gen_puts (scm_regular_string, "#wh(", port);
- else
- scm_gen_puts (scm_regular_string, "#w(", port);
- goto common_vector_printer;
-
- case scm_tc7_vector:
- ENTER_NESTED_DATA (pstate, exp, circref);
- scm_gen_puts (scm_regular_string, "#(", port);
- common_vector_printer:
- for (i = 0; i + 1 < SCM_LENGTH (exp); ++i)
- {
- /* CHECK_INTS; */
- scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
- scm_gen_putc (' ', port);
- }
- if (i < SCM_LENGTH (exp))
- {
- /* CHECK_INTS; */
- scm_iprin1 (SCM_VELTS (exp)[i], port, pstate);
- }
- scm_gen_putc (')', port);
- EXIT_NESTED_DATA (pstate);
- break;
- case scm_tc7_bvect:
- case scm_tc7_byvect:
- case scm_tc7_svect:
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
-#ifdef LONGLONGS
- case scm_tc7_llvect:
-#endif
- scm_raprin1 (exp, port, pstate);
- break;
- case scm_tcs_subrs:
- scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
- scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp))
- ? scm_mb_string
- : scm_regular_string),
- SCM_CHARS (SCM_SNAME (exp)), port);
- scm_gen_putc ('>', port);
- break;
-#ifdef CCLO
- case scm_tc7_cclo:
- scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
- scm_iprin1 (SCM_CCLO_SUBR (exp), port, pstate);
- scm_gen_putc ('>', port);
- break;
-#endif
- case scm_tc7_contin:
- scm_gen_puts (scm_regular_string, "#<continuation ", port);
- scm_intprint (SCM_LENGTH (exp), 10, port);
- scm_gen_puts (scm_regular_string, " @ ", port);
- scm_intprint ((long) SCM_CHARS (exp), 16, port);
- scm_gen_putc ('>', port);
- break;
- case scm_tc7_port:
- i = SCM_PTOBNUM (exp);
- if (i < scm_numptob
- && scm_ptobs[i].print
- && (scm_ptobs[i].print) (exp, port, pstate))
- break;
- goto punk;
- case scm_tc7_smob:
- ENTER_NESTED_DATA (pstate, exp, circref);
- i = SCM_SMOBNUM (exp);
- if (i < scm_numsmob && scm_smobs[i].print
- && (scm_smobs[i].print) (exp, port, pstate))
- {
- EXIT_NESTED_DATA (pstate);
- break;
- }
- EXIT_NESTED_DATA (pstate);
- default:
- punk:
- scm_ipruk ("type", exp, port);
- }
- }
-}
-
-/* Print states are necessary for circular reference safe printing.
- * They are also expensive to allocate. Therefore print states are
- * kept in a pool so that they can be reused.
- */
-
-void
-scm_prin1 (exp, port, writingp)
- SCM exp;
- SCM port;
- int writingp;
-{
- SCM handle = 0; /* Will GC protect the handle whilst unlinked */
- scm_print_state *pstate;
-
- /* First try to allocate a print state from the pool */
- SCM_DEFER_INTS;
- if (SCM_NNULLP (SCM_CDR (print_state_pool)))
- {
- handle = SCM_CDR (print_state_pool);
- SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
- }
- SCM_ALLOW_INTS;
-
- if (!handle)
- handle = scm_cons (make_print_state (), SCM_EOL);
-
- pstate = SCM_PRINT_STATE (SCM_CAR (handle));
- pstate->writingp = writingp;
- scm_iprin1 (exp, port, pstate);
-
- /* Return print state to pool */
- SCM_DEFER_INTS;
- SCM_SETCDR (handle, SCM_CDR (print_state_pool));
- SCM_SETCDR (print_state_pool, handle);
- SCM_ALLOW_INTS;
-}
-
-
-/* Print an integer.
- */
-
-void
-scm_intprint (n, radix, port)
- long n;
- int radix;
- SCM port;
-{
- char num_buf[SCM_INTBUFLEN];
- scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port);
-}
-
-/* Print an object of unrecognized type.
- */
-
-void
-scm_ipruk (hdr, ptr, port)
- char *hdr;
- SCM ptr;
- SCM port;
-{
- scm_gen_puts (scm_regular_string, "#<unknown-", port);
- scm_gen_puts (scm_regular_string, hdr, port);
- if (SCM_CELLP (ptr))
- {
- scm_gen_puts (scm_regular_string, " (0x", port);
- scm_intprint (SCM_CAR (ptr), 16, port);
- scm_gen_puts (scm_regular_string, " . 0x", port);
- scm_intprint (SCM_CDR (ptr), 16, port);
- scm_gen_puts (scm_regular_string, ") @", port);
- }
- scm_gen_puts (scm_regular_string, " 0x", port);
- scm_intprint (ptr, 16, port);
- scm_gen_putc ('>', port);
-}
-
-/* Print a list.
- */
-
-
-void
-scm_iprlist (hdr, exp, tlr, port, pstate)
- char *hdr;
- SCM exp;
- char tlr;
- SCM port;
- scm_print_state *pstate;
-{
- register int i;
- register SCM hare, tortoise;
- int floor = pstate->top - 2;
- scm_gen_puts (scm_regular_string, hdr, port);
- /* CHECK_INTS; */
- if (pstate->fancyp)
- goto fancy_printing;
-
- /* Run a hare and tortoise so that total time complexity will be
- O(depth * N) instead of O(N^2). */
- hare = SCM_CDR (exp);
- tortoise = exp;
- while (SCM_NIMP (hare) && SCM_ECONSP (hare))
- {
- if (hare == tortoise)
- goto fancy_printing;
- hare = SCM_CDR (hare);
- if (SCM_IMP (hare) || SCM_NECONSP (hare))
- break;
- hare = SCM_CDR (hare);
- tortoise = SCM_CDR (tortoise);
- }
-
- /* No cdr cycles intrinsic to this list */
- scm_iprin1 (SCM_CAR (exp), port, pstate);
- exp = SCM_CDR (exp);
- for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
- {
- if (SCM_NECONSP (exp))
- break;
- for (i = floor; i >= 0; --i)
- if (pstate->ref_stack[i] == exp)
- goto circref;
- PUSH_REF (pstate, exp);
- scm_gen_putc (' ', port);
- /* CHECK_INTS; */
- scm_iprin1 (SCM_CAR (exp), port, pstate);
- }
- if (SCM_NNULLP (exp))
- {
- scm_gen_puts (scm_regular_string, " . ", port);
- scm_iprin1 (exp, port, pstate);
- }
-
-end:
- scm_gen_putc (tlr, port);
- pstate->top = floor + 2;
- return;
-
-fancy_printing:
- {
- int n = pstate->length;
-
- scm_iprin1 (SCM_CAR (exp), port, pstate);
- exp = SCM_CDR (exp); --n;
- for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
- {
- if (SCM_NECONSP (exp))
- break;
- for (i = 0; i < pstate->top; ++i)
- if (pstate->ref_stack[i] == exp)
- goto fancy_circref;
- if (pstate->fancyp)
- {
- if (n == 0)
- {
- scm_gen_puts (scm_regular_string, " ...", port);
- goto skip_tail;
- }
- else
- --n;
- }
- PUSH_REF(pstate, exp);
- ++pstate->list_offset;
- scm_gen_putc (' ', port);
- /* CHECK_INTS; */
- scm_iprin1 (SCM_CAR (exp), port, pstate);
- }
- }
- if (SCM_NNULLP (exp))
- {
- scm_gen_puts (scm_regular_string, " . ", port);
- scm_iprin1 (exp, port, pstate);
- }
-skip_tail:
- pstate->list_offset -= pstate->top - floor - 2;
- goto end;
-
-fancy_circref:
- pstate->list_offset -= pstate->top - floor - 2;
-
-circref:
- scm_gen_puts (scm_regular_string, " . ", port);
- print_circref (port, pstate, exp);
- goto end;
-}
-
-
-
-SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
-
-SCM
-scm_write (obj, port)
- SCM obj;
- SCM port;
-{
- if (SCM_UNBNDP (port))
- port = scm_cur_outp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write);
- scm_prin1 (obj, port, 1);
-#ifdef HAVE_PIPE
-# ifdef EPIPE
- if (EPIPE == errno)
- scm_close_port (port);
-# endif
-#endif
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_display, "display", 1, 1, 0, scm_display);
-
-SCM
-scm_display (obj, port)
- SCM obj;
- SCM port;
-{
- if (SCM_UNBNDP (port))
- port = scm_cur_outp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
- scm_prin1 (obj, port, 0);
-#ifdef HAVE_PIPE
-# ifdef EPIPE
- if (EPIPE == errno)
- scm_close_port (port);
-# endif
-#endif
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
-
-SCM
-scm_newline (port)
- SCM port;
-{
- if (SCM_UNBNDP (port))
- port = scm_cur_outp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline);
- scm_gen_putc ('\n', port);
-#ifdef HAVE_PIPE
-# ifdef EPIPE
- if (EPIPE == errno)
- scm_close_port (port);
- else
-# endif
-#endif
- if (port == scm_cur_outp)
- scm_fflush (port);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
-
-SCM
-scm_write_char (chr, port)
- SCM chr;
- SCM port;
-{
- if (SCM_UNBNDP (port))
- port = scm_cur_outp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char);
- SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
- scm_gen_putc ((int) SCM_ICHR (chr), port);
-#ifdef HAVE_PIPE
-# ifdef EPIPE
- if (EPIPE == errno)
- scm_close_port (port);
-# endif
-#endif
- return SCM_UNSPECIFIED;
-}
-
-
-
-
-
-void
-scm_init_print ()
-{
- SCM vtable, type;
- scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
- vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr), SCM_INUM0, SCM_EOL);
- type = scm_make_struct (vtable,
- SCM_INUM0,
- scm_cons (scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)),
- SCM_EOL));
- print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL));
-#include "print.x"
-}
diff --git a/libguile/print.h b/libguile/print.h
deleted file mode 100644
index cb326fb5b..000000000
--- a/libguile/print.h
+++ /dev/null
@@ -1,100 +0,0 @@
-/* classes: h_files */
-
-#ifndef PRINTH
-#define PRINTH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-#include "libguile/options.h"
-
-extern scm_option scm_print_opts[];
-
-#define SCM_PRINT_CLOSURE ((SCM) scm_print_opts[0].val)
-#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val)
-#define SCM_N_PRINT_OPTIONS 2
-
-/* State information passed around during printing.
- */
-#define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj))
-
-#define RESET_PRINT_STATE(pstate) \
-{ \
- pstate->list_offset = 0; \
- pstate->top = 0; \
-}
-
-#define SCM_WRITINGP(pstate) ((pstate)->writingp)
-#define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); }
-
-#define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwpwuwuwuruopr"
-typedef struct scm_print_state {
- SCM handle; /* Struct handle */
- unsigned long writingp; /* Writing? */
- unsigned long fancyp; /* Fancy printing? */
- unsigned long level; /* Max level */
- unsigned long length; /* Max number of objects per level */
- SCM hot_ref; /* Hot reference */
- unsigned long list_offset;
- unsigned long top; /* Top of reference stack */
- unsigned long ceiling; /* Max size of reference stack */
- SCM *ref_stack; /* Stack of references used during
- circular reference detection */
- SCM ref_vect;
-} scm_print_state;
-
-extern SCM scm_print_options SCM_P ((SCM setting));
-SCM scm_make_print_state SCM_P ((void));
-void scm_free_print_state SCM_P ((SCM print_state));
-extern void scm_intprint SCM_P ((long n, int radix, SCM port));
-extern void scm_ipruk SCM_P ((char *hdr, SCM ptr, SCM port));
-extern void scm_iprlist SCM_P ((char *hdr, SCM exp, char tlr, SCM port, scm_print_state *pstate));
-extern void scm_prin1 SCM_P ((SCM exp, SCM port, int writingp));
-extern void scm_iprin1 SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-extern SCM scm_write SCM_P ((SCM obj, SCM port));
-extern SCM scm_display SCM_P ((SCM obj, SCM port));
-extern SCM scm_newline SCM_P ((SCM port));
-extern SCM scm_write_char SCM_P ((SCM chr, SCM port));
-extern void scm_init_print SCM_P ((void));
-
-#endif /* PRINTH */
diff --git a/libguile/procprop.c b/libguile/procprop.c
deleted file mode 100644
index 42ca7dbd9..000000000
--- a/libguile/procprop.c
+++ /dev/null
@@ -1,138 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "alist.h"
-#include "eval.h"
-
-#include "procprop.h"
-
-
-static SCM
-scm_stand_in_scm_proc(proc)
- SCM proc;
-{
- SCM answer;
- answer = scm_assoc (proc, scm_stand_in_procs);
- if (answer == SCM_BOOL_F)
- {
- answer = scm_closure (scm_listify (SCM_EOL, SCM_BOOL_F, SCM_UNDEFINED),
- SCM_EOL);
- scm_stand_in_procs = scm_cons (scm_cons (proc, answer),
- scm_stand_in_procs);
- }
- else
- answer = SCM_CDR (answer);
- return answer;
-}
-
-SCM_PROC(s_procedure_properties, "procedure-properties", 1, 0, 0, scm_procedure_properties);
-
-SCM
-scm_procedure_properties (proc)
- SCM proc;
-{
- SCM_ASSERT (scm_procedure_p (proc), proc, SCM_ARG1, s_procedure_properties);
- if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc)))
- proc = scm_stand_in_scm_proc(proc);
- return SCM_PROCPROPS (proc);
-}
-
-SCM_PROC(s_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0, scm_set_procedure_properties_x);
-
-SCM
-scm_set_procedure_properties_x (proc, new_val)
- SCM proc;
- SCM new_val;
-{
- if (!(SCM_NIMP (proc) && SCM_CLOSUREP (proc)))
- proc = scm_stand_in_scm_proc(proc);
- SCM_ASSERT (SCM_NIMP (proc) && SCM_CLOSUREP (proc), proc, SCM_ARG1, s_set_procedure_properties_x);
- SCM_SETPROCPROPS (proc, new_val);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC(s_procedure_property, "procedure-property", 2, 0, 0, scm_procedure_property);
-
-SCM
-scm_procedure_property (p, k)
- SCM p;
- SCM k;
-{
- SCM assoc;
- if (!(SCM_NIMP (p) && SCM_CLOSUREP (p)))
- p = scm_stand_in_scm_proc(p);
- SCM_ASSERT (scm_procedure_p (p), p, SCM_ARG1, s_procedure_property);
- assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
- return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
-}
-
-SCM_PROC(s_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, scm_set_procedure_property_x);
-
-SCM
-scm_set_procedure_property_x (p, k, v)
- SCM p;
- SCM k;
- SCM v;
-{
- SCM assoc;
- if (!(SCM_NIMP (p) && SCM_CLOSUREP (p)))
- p = scm_stand_in_scm_proc(p);
- SCM_ASSERT (SCM_NIMP (p) && SCM_CLOSUREP (p), p, SCM_ARG1, s_set_procedure_property_x);
- assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
- if (SCM_NIMP (assoc))
- SCM_SETCDR (assoc, v);
- else
- SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
- return SCM_UNSPECIFIED;
-}
-
-
-
-
-void
-scm_init_procprop ()
-{
-#include "procprop.x"
-}
-
diff --git a/libguile/procprop.h b/libguile/procprop.h
deleted file mode 100644
index cac97edd1..000000000
--- a/libguile/procprop.h
+++ /dev/null
@@ -1,61 +0,0 @@
-/* classes: h_files */
-
-#ifndef PROCPROPH
-#define PROCPROPH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-extern SCM scm_i_name;
-
-
-
-extern SCM scm_procedure_properties SCM_P ((SCM proc));
-extern SCM scm_set_procedure_properties_x SCM_P ((SCM proc, SCM new_val));
-extern SCM scm_procedure_property SCM_P ((SCM p, SCM k));
-extern SCM scm_set_procedure_property_x SCM_P ((SCM p, SCM k, SCM v));
-extern void scm_init_procprop SCM_P ((void));
-
-#endif /* PROCPROPH */
diff --git a/libguile/procs.c b/libguile/procs.c
deleted file mode 100644
index a8ccd0979..000000000
--- a/libguile/procs.c
+++ /dev/null
@@ -1,199 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-
-#include "procs.h"
-
-
-
-/* {Procedures}
- */
-
-
-SCM
-scm_make_subr_opt (name, type, fcn, set)
- char *name;
- int type;
- SCM (*fcn) ();
- int set;
-{
- SCM symcell;
- long tmp;
- register SCM z;
- symcell = scm_sysintern (name, SCM_UNDEFINED);
- tmp = ((((SCM_CELLPTR) (SCM_CAR (symcell))) - scm_heap_org) << 8);
- if ((tmp >> 8) != ((SCM_CELLPTR) (SCM_CAR (symcell)) - scm_heap_org))
- tmp = 0;
- SCM_NEWCELL (z);
- SCM_SUBRF (z) = fcn;
- SCM_SETCAR (z, tmp + type);
- if (set)
- SCM_SETCDR (symcell, z);
- return z;
-}
-
-
-
-SCM
-scm_make_subr (name, type, fcn)
- char *name;
- int type;
- SCM (*fcn) ();
-{
- return scm_make_subr_opt (name, type, fcn, 1);
-}
-
-#ifdef CCLO
-
-SCM
-scm_makcclo (proc, len)
- SCM proc;
- long len;
-{
- SCM s;
- SCM_NEWCELL (s);
- SCM_DEFER_INTS;
- SCM_SETCHARS (s, scm_must_malloc (len * sizeof (SCM), "compiled-closure"));
- SCM_SETLENGTH (s, len, scm_tc7_cclo);
- while (--len)
- SCM_VELTS (s)[len] = SCM_UNSPECIFIED;
- SCM_CCLO_SUBR (s) = proc;
- SCM_ALLOW_INTS;
- return s;
-}
-#endif
-
-
-
-SCM_PROC(s_procedure_p, "procedure?", 1, 0, 0, scm_procedure_p);
-
-SCM
-scm_procedure_p (obj)
- SCM obj;
-{
- if (SCM_NIMP (obj))
- switch (SCM_TYP7 (obj))
- {
- case scm_tcs_closures:
- case scm_tc7_contin:
- case scm_tcs_subrs:
-#ifdef CCLO
- case scm_tc7_cclo:
-#endif
- return SCM_BOOL_T;
- default:
- return SCM_BOOL_F;
- }
- return SCM_BOOL_F;
-}
-
-SCM_PROC(s_closure_p, "closure?", 1, 0, 0, scm_closure_p);
-
-SCM
-scm_closure_p (obj)
- SCM obj;
-{
- if (SCM_NIMP (obj))
- switch (SCM_TYP7 (obj))
- {
- case scm_tcs_closures:
- return SCM_BOOL_T;
- default: ;
- }
- return SCM_BOOL_F;
-}
-
-#ifdef __STDC__
-SCM
-scm_thunk_p (SCM obj)
-#else
-SCM
-scm_thunk_p (obj)
- SCM obj;
-#endif
-{
- if (SCM_NIMP (obj))
- switch (SCM_TYP7 (obj))
- {
- case scm_tcs_closures:
- if (SCM_NULLP (SCM_CAR (SCM_CODE (obj))))
- return SCM_BOOL_T;
- case scm_tc7_subr_0:
- case scm_tc7_subr_1o:
- case scm_tc7_lsubr:
- case scm_tc7_rpsubr:
- case scm_tc7_asubr:
-#ifdef CCLO
- case scm_tc7_cclo:
-#endif
- return SCM_BOOL_T;
- default:
- ;
- }
- return SCM_BOOL_F;
-}
-
-
-
-void
-scm_init_iprocs(subra, type)
- scm_iproc *subra;
- int type;
-{
- for(;subra->scm_string; subra++)
- scm_make_subr(subra->scm_string,
- type,
- subra->cproc);
-}
-
-
-
-
-
-void
-scm_init_procs ()
-{
-#include "procs.x"
-}
-
diff --git a/libguile/procs.h b/libguile/procs.h
deleted file mode 100644
index 50345e784..000000000
--- a/libguile/procs.h
+++ /dev/null
@@ -1,103 +0,0 @@
-/* classes: h_files */
-
-#ifndef PROCSH
-#define PROCSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-
-/* Subrs
- */
-
-typedef struct scm_subr
-{
- long sname;
- SCM (*cproc) ();
-} scm_subr;
-
-typedef struct scm_iproc
-{
- char *scm_string;
- SCM (*cproc) ();
-} scm_iproc;
-
-typedef struct scm_dsubr
-{
- long sname;
- double (*dproc) ();
-} scm_dsubr;
-
-#define SCM_SNAME(x) ((SCM_CAR(x)>>8)?(SCM)(scm_heap_org+(SCM_CAR(x)>>8)):scm_nullstr)
-#define SCM_SUBRF(x) (((scm_subr *)(SCM2PTR(x)))->cproc)
-#define SCM_DSUBRF(x) (((scm_dsubr *)(SCM2PTR(x)))->dproc)
-#define SCM_CCLO_SUBR(x) (SCM_VELTS(x)[0])
-
-/* Closures
- */
-
-#define SCM_CLOSUREP(x) (SCM_TYP3(x)==scm_tc3_closure)
-#define SCM_CLOSCAR(x) (SCM_CAR(x)-scm_tc3_closure)
-#define SCM_CODE(x) SCM_CAR(SCM_CLOSCAR (x))
-#define SCM_PROCPROPS(x) SCM_CDR(SCM_CLOSCAR (x))
-#define SCM_SETPROCPROPS(x, p) SCM_SETCDR(SCM_CLOSCAR (x), p)
-#define SCM_SETCODE(x, e) (SCM_SETCAR (x, scm_cons ((e), SCM_EOL) + scm_tc3_closure))
-#define SCM_ENV(x) SCM_CDR(x)
-#define SCM_SETENV(x, e) SCM_SETCDR (x, e)
-#define SCM_TOP_LEVEL(SCM_ENV) (SCM_NULLP(SCM_ENV) || (SCM_BOOL_T == scm_procedure_p (SCM_CAR (SCM_ENV))))
-
-
-
-extern SCM scm_make_subr SCM_P ((char *name, int type, SCM (*fcn) ()));
-extern SCM scm_make_subr_opt SCM_P ((char *name, int type, SCM (*fcn) (),
- int set));
-extern SCM scm_makcclo SCM_P ((SCM proc, long len));
-extern SCM scm_procedure_p SCM_P ((SCM obj));
-extern SCM scm_thunk_p SCM_P ((SCM obj));
-extern void scm_init_iprocs SCM_P ((scm_iproc *subra, int type));
-extern void scm_init_procs SCM_P ((void));
-
-
-#endif /* PROCSH */
diff --git a/libguile/ramap.c b/libguile/ramap.c
deleted file mode 100644
index a139566fc..000000000
--- a/libguile/ramap.c
+++ /dev/null
@@ -1,2127 +0,0 @@
-/* Copyright (C) 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "unif.h"
-#include "smob.h"
-#include "chars.h"
-#include "eq.h"
-#include "eval.h"
-#include "feature.h"
-
-#include "ramap.h"
-
-
-#ifdef ARRAYS
-
-typedef struct
-{
- char *name;
- SCM sproc;
- int (*vproc) ();
-} ra_iproc;
-
-static ra_iproc ra_rpsubrs[];
-static ra_iproc ra_asubrs[];
-
-#define BVE_REF(a, i) ((SCM_VELTS(a)[(i)/SCM_LONG_BIT] & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0)
-#define BVE_SET(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] |= (1L<<((i)%SCM_LONG_BIT)))
-#define BVE_CLR(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] &= ~(1L<<((i)%SCM_LONG_BIT)))
-
-/* Fast, recycling scm_vector ref */
-#define RVREF(ra, i, e) (e = scm_cvref(ra, i, e))
-
-/* #define RVREF(ra, i, e) (scm_cvref(ra, i, SCM_UNDEFINED)) to turn off */
-
-/* IVDEP means "ignore scm_vector dependencies", meaning we guarantee that
- elements of scm_vector operands are not aliased */
-#ifdef _UNICOS
-#define IVDEP(test, line) if (test) {_Pragma("ivdep"); line} else {line}
-#else
-#define IVDEP(test, line) line
-#endif
-
-
-
-/* inds must be a uvect or ivect, no check. */
-
-
-static scm_sizet cind SCM_P ((SCM ra, SCM inds));
-
-static scm_sizet
-cind (ra, inds)
- SCM ra;
- SCM inds;
-{
- scm_sizet i;
- int k;
- long *ve = SCM_VELTS (inds);
- if (!SCM_ARRAYP (ra))
- return *ve;
- i = SCM_ARRAY_BASE (ra);
- for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
- i += (ve[k] - SCM_ARRAY_DIMS (ra)[k].lbnd) * SCM_ARRAY_DIMS (ra)[k].inc;
- return i;
-}
-
-
-/* Checker for scm_array mapping functions:
- return values: 4 --> shapes, increments, and bases are the same;
- 3 --> shapes and increments are the same;
- 2 --> shapes are the same;
- 1 --> ras are at least as big as ra0;
- 0 --> no match.
- */
-
-int
-scm_ra_matchp (ra0, ras)
- SCM ra0;
- SCM ras;
-{
- SCM ra1;
- scm_array_dim dims;
- scm_array_dim *s0 = &dims;
- scm_array_dim *s1;
- scm_sizet bas0 = 0;
- int i, ndim = 1;
- int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
- if SCM_IMP
- (ra0) return 0;
- switch (SCM_TYP7 (ra0))
- {
- default:
- return 0;
- case scm_tc7_vector:
- case scm_tc7_string:
- case scm_tc7_bvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- s0->lbnd = 0;
- s0->inc = 1;
- s0->ubnd = (long) SCM_LENGTH (ra0) - 1;
- break;
- case scm_tc7_smob:
- if (!SCM_ARRAYP (ra0))
- return 0;
- ndim = SCM_ARRAY_NDIM (ra0);
- s0 = SCM_ARRAY_DIMS (ra0);
- bas0 = SCM_ARRAY_BASE (ra0);
- break;
- }
- while SCM_NIMP
- (ras)
- {
- ra1 = SCM_CAR (ras);
- if SCM_IMP
- (ra1) return 0;
- switch SCM_TYP7
- (ra1)
- {
- default:
- return 0;
- case scm_tc7_vector:
- case scm_tc7_string:
- case scm_tc7_bvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- if (1 != ndim)
- return 0;
- switch (exact)
- {
- case 4:
- if (0 != bas0)
- exact = 3;
- case 3:
- if (1 != s0->inc)
- exact = 2;
- case 2:
- if ((0 == s0->lbnd) && (s0->ubnd == SCM_LENGTH (ra1) - 1))
- break;
- exact = 1;
- case 1:
- if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1))
- return 0;
- }
- break;
- case scm_tc7_smob:
- if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1))
- return 0;
- s1 = SCM_ARRAY_DIMS (ra1);
- if (bas0 != SCM_ARRAY_BASE (ra1))
- exact = 3;
- for (i = 0; i < ndim; i++)
- switch (exact)
- {
- case 4:
- case 3:
- if (s0[i].inc != s1[i].inc)
- exact = 2;
- case 2:
- if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
- break;
- exact = 1;
- default:
- if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
- return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
- }
- break;
- }
- ras = SCM_CDR (ras);
- }
- return exact;
-}
-
-static char s_ra_mismatch[] = "array shape mismatch";
-
-int
-scm_ramapc (cproc, data, ra0, lra, what)
- int (*cproc) ();
- SCM data;
- SCM ra0;
- SCM lra;
- char *what;
-{
- SCM inds, z;
- SCM vra0, ra1, vra1;
- SCM lvra, *plvra;
- long *vinds;
- int k, kmax;
- switch (scm_ra_matchp (ra0, lra))
- {
- default:
- case 0:
- scm_wta (ra0, s_ra_mismatch, what);
- case 2:
- case 3:
- case 4: /* Try unrolling arrays */
- kmax = (SCM_ARRAYP (ra0) ? SCM_ARRAY_NDIM (ra0) - 1 : 0);
- if (kmax < 0)
- goto gencase;
- vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
- if SCM_IMP
- (vra0) goto gencase;
- if (!SCM_ARRAYP (vra0))
- {
- vra1 = scm_make_ra (1);
- SCM_ARRAY_BASE (vra1) = 0;
- SCM_ARRAY_DIMS (vra1)->lbnd = 0;
- SCM_ARRAY_DIMS (vra1)->ubnd = SCM_LENGTH (vra0) - 1;
- SCM_ARRAY_DIMS (vra1)->inc = 1;
- SCM_ARRAY_V (vra1) = vra0;
- vra0 = vra1;
- }
- lvra = SCM_EOL;
- plvra = &lvra;
- for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
- {
- ra1 = SCM_CAR (z);
- vra1 = scm_make_ra (1);
- SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd;
- SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd;
- if (!SCM_ARRAYP (ra1))
- {
- SCM_ARRAY_BASE (vra1) = 0;
- SCM_ARRAY_DIMS (vra1)->inc = 1;
- SCM_ARRAY_V (vra1) = ra1;
- }
- else if (!SCM_ARRAY_CONTP (ra1))
- goto gencase;
- else
- {
- SCM_ARRAY_BASE (vra1) = SCM_ARRAY_BASE (ra1);
- SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc;
- SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1);
- }
- *plvra = scm_cons (vra1, SCM_EOL);
- plvra = SCM_CDRLOC (*plvra);
- }
- return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
- case 1:
- gencase: /* Have to loop over all dimensions. */
- vra0 = scm_make_ra (1);
- if SCM_ARRAYP
- (ra0)
- {
- kmax = SCM_ARRAY_NDIM (ra0) - 1;
- if (kmax < 0)
- {
- SCM_ARRAY_DIMS (vra0)->lbnd = 0;
- SCM_ARRAY_DIMS (vra0)->ubnd = 0;
- SCM_ARRAY_DIMS (vra0)->inc = 1;
- }
- else
- {
- SCM_ARRAY_DIMS (vra0)->lbnd = SCM_ARRAY_DIMS (ra0)[kmax].lbnd;
- SCM_ARRAY_DIMS (vra0)->ubnd = SCM_ARRAY_DIMS (ra0)[kmax].ubnd;
- SCM_ARRAY_DIMS (vra0)->inc = SCM_ARRAY_DIMS (ra0)[kmax].inc;
- }
- SCM_ARRAY_BASE (vra0) = SCM_ARRAY_BASE (ra0);
- SCM_ARRAY_V (vra0) = SCM_ARRAY_V (ra0);
- }
- else
- {
- kmax = 0;
- SCM_ARRAY_DIMS (vra0)->lbnd = 0;
- SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1;
- SCM_ARRAY_DIMS (vra0)->inc = 1;
- SCM_ARRAY_BASE (vra0) = 0;
- SCM_ARRAY_V (vra0) = ra0;
- ra0 = vra0;
- }
- lvra = SCM_EOL;
- plvra = &lvra;
- for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
- {
- ra1 = SCM_CAR (z);
- vra1 = scm_make_ra (1);
- SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd;
- SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd;
- if SCM_ARRAYP
- (ra1)
- {
- if (kmax >= 0)
- SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc;
- SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1);
- }
- else
- {
- SCM_ARRAY_DIMS (vra1)->inc = 1;
- SCM_ARRAY_V (vra1) = ra1;
- }
- *plvra = scm_cons (vra1, SCM_EOL);
- plvra = SCM_CDRLOC (*plvra);
- }
- inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L));
- vinds = (long *) SCM_VELTS (inds);
- for (k = 0; k <= kmax; k++)
- vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd;
- k = kmax;
- do
- {
- if (k == kmax)
- {
- SCM y = lra;
- SCM_ARRAY_BASE (vra0) = cind (ra0, inds);
- for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
- SCM_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), inds);
- if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
- return 0;
- k--;
- continue;
- }
- if (vinds[k] < SCM_ARRAY_DIMS (ra0)[k].ubnd)
- {
- vinds[k]++;
- k++;
- continue;
- }
- vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd - 1;
- k--;
- }
- while (k >= 0);
- return 1;
- }
-}
-
-
-static char s_array_fill_x[];
-
-int
-scm_array_fill_int (ra, fill, ignore)
- SCM ra;
- SCM fill;
- SCM ignore;
-{
- scm_sizet i, n = SCM_ARRAY_DIMS (ra)->ubnd - SCM_ARRAY_DIMS (ra)->lbnd + 1;
- long inc = SCM_ARRAY_DIMS (ra)->inc;
- scm_sizet base = SCM_ARRAY_BASE (ra);
- ra = SCM_ARRAY_V (ra);
- switch SCM_TYP7
- (ra)
- {
- default:
- for (i = base; n--; i += inc)
- scm_array_set_x (ra, fill, SCM_MAKINUM (i));
- break;
- case scm_tc7_vector:
- for (i = base; n--; i += inc)
- SCM_VELTS (ra)[i] = fill;
- break;
- case scm_tc7_string:
- SCM_ASRTGO (SCM_ICHRP (fill), badarg2);
- for (i = base; n--; i += inc)
- SCM_CHARS (ra)[i] = SCM_ICHR (fill);
- break;
- case scm_tc7_bvect:
- {
- long *ve = (long *) SCM_VELTS (ra);
- if (1 == inc && (n >= SCM_LONG_BIT || n == SCM_LENGTH (ra)))
- {
- i = base / SCM_LONG_BIT;
- if (SCM_BOOL_F == fill)
- {
- if (base % SCM_LONG_BIT) /* leading partial word */
- ve[i++] &= ~(~0L << (base % SCM_LONG_BIT));
- for (; i < (base + n) / SCM_LONG_BIT; i++)
- ve[i] = 0L;
- if ((base + n) % SCM_LONG_BIT) /* trailing partial word */
- ve[i] &= (~0L << ((base + n) % SCM_LONG_BIT));
- }
- else if (SCM_BOOL_T == fill)
- {
- if (base % SCM_LONG_BIT)
- ve[i++] |= ~0L << (base % SCM_LONG_BIT);
- for (; i < (base + n) / SCM_LONG_BIT; i++)
- ve[i] = ~0L;
- if ((base + n) % SCM_LONG_BIT)
- ve[i] |= ~(~0L << ((base + n) % SCM_LONG_BIT));
- }
- else
- badarg2:scm_wta (fill, (char *) SCM_ARG2, s_array_fill_x);
- }
- else
- {
- if (SCM_BOOL_F == fill)
- for (i = base; n--; i += inc)
- ve[i / SCM_LONG_BIT] &= ~(1L << (i % SCM_LONG_BIT));
- else if (SCM_BOOL_T == fill)
- for (i = base; n--; i += inc)
- ve[i / SCM_LONG_BIT] |= (1L << (i % SCM_LONG_BIT));
- else
- goto badarg2;
- }
- break;
- }
- case scm_tc7_uvect:
- SCM_ASRTGO (0 <= SCM_INUM (fill), badarg2);
- case scm_tc7_ivect:
- SCM_ASRTGO (SCM_INUMP (fill), badarg2);
- {
- long f = SCM_INUM (fill), *ve = (long *) SCM_VELTS (ra);
- for (i = base; n--; i += inc)
- ve[i] = f;
- break;
- }
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float f, *ve = (float *) SCM_VELTS (ra);
- SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
- f = SCM_REALPART (fill);
- for (i = base; n--; i += inc)
- ve[i] = f;
- break;
- }
-#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double f, *ve = (double *) SCM_VELTS (ra);
- SCM_ASRTGO (SCM_NIMP (fill) && SCM_REALP (fill), badarg2);
- f = SCM_REALPART (fill);
- for (i = base; n--; i += inc)
- ve[i] = f;
- break;
- }
- case scm_tc7_cvect:
- {
- double fr, fi;
- double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra);
- SCM_ASRTGO (SCM_NIMP (fill) && SCM_INEXP (fill), badarg2);
- fr = SCM_REALPART (fill);
- fi = (SCM_CPLXP (fill) ? SCM_IMAG (fill) : 0.0);
- for (i = base; n--; i += inc)
- {
- ve[i][0] = fr;
- ve[i][1] = fi;
- }
- break;
- }
-#endif /* SCM_FLOATS */
- }
- return 1;
-}
-
-SCM_PROC(s_array_fill_x, "array-fill!", 2, 0, 0, scm_array_fill_x);
-
-SCM
-scm_array_fill_x (ra, fill)
- SCM ra;
- SCM fill;
-{
- scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, s_array_fill_x);
- return SCM_UNSPECIFIED;
-}
-
-
-
-
-static int racp SCM_P ((SCM dst, SCM src));
-
-static int
-racp (src, dst)
- SCM dst;
- SCM src;
-{
- long n = (SCM_ARRAY_DIMS (src)->ubnd - SCM_ARRAY_DIMS (src)->lbnd + 1);
- long inc_d, inc_s = SCM_ARRAY_DIMS (src)->inc;
- scm_sizet i_d, i_s = SCM_ARRAY_BASE (src);
- dst = SCM_CAR (dst);
- inc_d = SCM_ARRAY_DIMS (dst)->inc;
- i_d = SCM_ARRAY_BASE (dst);
- src = SCM_ARRAY_V (src);
- dst = SCM_ARRAY_V (dst);
- switch SCM_TYP7
- (dst)
- {
- default:
- gencase: case scm_tc7_vector:
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d));
- break;
- case scm_tc7_string:
- if (scm_tc7_string != SCM_TYP7 (dst))
- goto gencase;
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- SCM_CHARS (dst)[i_d] = SCM_CHARS (src)[i_s];
- break;
- case scm_tc7_bvect:
- if (scm_tc7_bvect != SCM_TYP7 (dst))
- goto gencase;
- if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT)
- {
- long *sv = (long *) SCM_VELTS (src);
- long *dv = (long *) SCM_VELTS (dst);
- sv += i_s / SCM_LONG_BIT;
- dv += i_d / SCM_LONG_BIT;
- if (i_s % SCM_LONG_BIT)
- { /* leading partial word */
- *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT)));
- dv++;
- sv++;
- n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT);
- }
- IVDEP (src != dst,
- for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++)
- * dv = *sv;)
- if (n) /* trailing partial word */
- *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n));
- }
- else
- {
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- if (SCM_VELTS (src)[i_s / SCM_LONG_BIT] & (1L << (i_s % SCM_LONG_BIT)))
- SCM_VELTS (dst)[i_d / SCM_LONG_BIT] |= (1L << (i_d % SCM_LONG_BIT));
- else
- SCM_VELTS (dst)[i_d / SCM_LONG_BIT] &= ~(1L << (i_d % SCM_LONG_BIT));
- }
- break;
- case scm_tc7_uvect:
- if (scm_tc7_uvect != SCM_TYP7 (src))
- goto gencase;
- else
- {
- long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = s[i_s];)
- break;
- }
- case scm_tc7_ivect:
- if (scm_tc7_uvect != SCM_TYP7 (src) && scm_tc7_ivect != SCM_TYP7 (src))
- goto gencase;
- else
- {
- long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = s[i_s];)
- break;
- }
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *d = (float *) SCM_VELTS (dst);
- float *s = (float *) SCM_VELTS (src);
- switch SCM_TYP7
- (src)
- {
- default:
- goto gencase;
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((long *) s)[i_s];)
- break;
- case scm_tc7_fvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = s[i_s];)
- break;
- case scm_tc7_dvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((double *) s)[i_s];)
- break;
- }
- break;
- }
-#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *d = (double *) SCM_VELTS (dst);
- double *s = (double *) SCM_VELTS (src);
- switch SCM_TYP7
- (src)
- {
- default:
- goto gencase;
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((long *) s)[i_s];)
- break;
- case scm_tc7_fvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((float *) s)[i_s];)
- break;
- case scm_tc7_dvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = s[i_s];)
- break;
- }
- break;
- }
- case scm_tc7_cvect:
- {
- double (*d)[2] = (double (*)[2]) SCM_VELTS (dst);
- double (*s)[2] = (double (*)[2]) SCM_VELTS (src);
- switch SCM_TYP7
- (src)
- {
- default:
- goto gencase;
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- {
- d[i_d][0] = ((long *) s)[i_s];
- d[i_d][1] = 0.0;
- }
- )
- break;
- case scm_tc7_fvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- {
- d[i_d][0] = ((float *) s)[i_s];
- d[i_d][1] = 0.0;
- }
- )
- break;
- case scm_tc7_dvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- {
- d[i_d][0] = ((double *) s)[i_s];
- d[i_d][1] = 0.0;
- }
- )
- break;
- case scm_tc7_cvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- {
- d[i_d][0] = s[i_s][0];
- d[i_d][1] = s[i_s][1];
- }
- )
- }
- break;
- }
- }
-#endif /* SCM_FLOATS */
- return 1;
-}
-
-
-SCM_PROC(s_serial_array_copy_x, "serial-array-copy!", 2, 0, 0, scm_array_copy_x);
-SCM_PROC(s_array_copy_x, "array-copy!", 2, 0, 0, scm_array_copy_x);
-
-SCM
-scm_array_copy_x (src, dst)
- SCM src;
- SCM dst;
-{
- scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), s_array_copy_x);
- return SCM_UNSPECIFIED;
-}
-
-/* Functions callable by ARRAY-MAP! */
-
-
-int
-scm_ra_eqp (ra0, ras)
- SCM ra0;
- SCM ras;
-{
- SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
- long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- ra1 = SCM_ARRAY_V (ra1);
- ra2 = SCM_ARRAY_V (ra2);
- switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
- {
- default:
- {
- SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- if SCM_FALSEP
- (scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))
- BVE_CLR (ra0, i0);
- break;
- }
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2])
- BVE_CLR (ra0, i0);
- break;
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2])
- BVE_CLR (ra0, i0);
- break;
-#endif /*SCM_SINGLES*/
- case scm_tc7_dvect:
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2])
- BVE_CLR (ra0, i0);
- break;
- case scm_tc7_cvect:
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] ||
- ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1])
- BVE_CLR (ra0, i0);
- break;
-#endif /*SCM_FLOATS*/
- }
- return 1;
-}
-
-/* opt 0 means <, nonzero means >= */
-
-static int ra_compare SCM_P ((SCM ra0, SCM ra1, SCM ra2, int opt));
-
-static int
-ra_compare (ra0, ra1, ra2, opt)
- SCM ra0;
- SCM ra1;
- SCM ra2;
- int opt;
-{
- long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- ra1 = SCM_ARRAY_V (ra1);
- ra2 = SCM_ARRAY_V (ra2);
- switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
- {
- default:
- {
- SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- if (opt ?
- SCM_NFALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) :
- SCM_FALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
- BVE_CLR (ra0, i0);
- break;
- }
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- {
- if BVE_REF
- (ra0, i0)
- if (opt ?
- SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] :
- SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2])
- BVE_CLR (ra0, i0);
- }
- break;
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- if (opt ?
- ((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] :
- ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2])
- BVE_CLR (ra0, i0);
- break;
-#endif /*SCM_SINGLES*/
- case scm_tc7_dvect:
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- if (opt ?
- ((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] :
- ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2])
- BVE_CLR (ra0, i0);
- break;
-#endif /*SCM_FLOATS*/
- }
- return 1;
-}
-
-
-
-int
-scm_ra_lessp (ra0, ras)
- SCM ra0;
- SCM ras;
-{
- return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
-}
-
-
-int
-scm_ra_leqp (ra0, ras)
- SCM ra0;
- SCM ras;
-{
- return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
-}
-
-
-int
-scm_ra_grp (ra0, ras)
- SCM ra0;
- SCM ras;
-{
- return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
-}
-
-
-int
-scm_ra_greqp (ra0, ras)
- SCM ra0;
- SCM ras;
-{
- return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
-}
-
-
-
-int
-scm_ra_sum (ra0, ras)
- SCM ra0;
- SCM ras;
-{
- long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- if SCM_NNULLP
- (ras)
- {
- SCM ra1 = SCM_CAR (ras);
- scm_sizet i1 = SCM_ARRAY_BASE (ra1);
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
- SCM_MAKINUM (i0));
- break;
- }
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- {
- long *v0 = SCM_VELTS (ra0);
- long *v1 = SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] += v1[i1];)
- break;
- }
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- float *v1 = (float *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] += v1[i1];)
- break;
- }
-#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- double *v1 = (double *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] += v1[i1];)
- break;
- }
- case scm_tc7_cvect:
- {
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
- double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- v0[i0][0] += v1[i1][0];
- v0[i0][1] += v1[i1][1];
- }
- );
- break;
- }
-#endif /* SCM_FLOATS */
- }
- }
- return 1;
-}
-
-
-
-int
-scm_ra_difference (ra0, ras)
- SCM ra0;
- SCM ras;
-{
- long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- if SCM_NULLP
- (ras)
- {
- switch SCM_TYP7
- (ra0)
- {
- default:
- {
- SCM e0 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0)
- scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
- break;
- }
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- v0[i0] = -v0[i0];
- break;
- }
-#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- v0[i0] = -v0[i0];
- break;
- }
- case scm_tc7_cvect:
- {
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- {
- v0[i0][0] = -v0[i0][0];
- v0[i0][1] = -v0[i0][1];
- }
- break;
- }
-#endif /* SCM_FLOATS */
- }
- }
- else
- {
- SCM ra1 = SCM_CAR (ras);
- scm_sizet i1 = SCM_ARRAY_BASE (ra1);
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
- break;
- }
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- float *v1 = (float *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] -= v1[i1];)
- break;
- }
-#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- double *v1 = (double *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] -= v1[i1];)
- break;
- }
- case scm_tc7_cvect:
- {
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
- double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- v0[i0][0] -= v1[i1][0];
- v0[i0][1] -= v1[i1][1];
- }
- )
- break;
- }
-#endif /* SCM_FLOATS */
- }
- }
- return 1;
-}
-
-
-
-int
-scm_ra_product (ra0, ras)
- SCM ra0;
- SCM ras;
-{
- long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- if SCM_NNULLP
- (ras)
- {
- SCM ra1 = SCM_CAR (ras);
- scm_sizet i1 = SCM_ARRAY_BASE (ra1);
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
- SCM_MAKINUM (i0));
- break;
- }
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- {
- long *v0 = SCM_VELTS (ra0);
- long *v1 = SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] *= v1[i1];)
- break;
- }
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- float *v1 = (float *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] *= v1[i1];)
- break;
- }
-#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- double *v1 = (double *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] *= v1[i1];)
- break;
- }
- case scm_tc7_cvect:
- {
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
- register double r;
- double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- r = v0[i0][0] * v1[i1][0] - v0[i0][1] * v1[i1][1];
- v0[i0][1] = v0[i0][0] * v1[i1][1] + v0[i0][1] * v1[i1][0];
- v0[i0][0] = r;
- }
- );
- break;
- }
-#endif /* SCM_FLOATS */
- }
- }
- return 1;
-}
-
-
-int
-scm_ra_divide (ra0, ras)
- SCM ra0;
- SCM ras;
-{
- long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- if SCM_NULLP
- (ras)
- {
- switch SCM_TYP7
- (ra0)
- {
- default:
- {
- SCM e0 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0)
- scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
- break;
- }
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- v0[i0] = 1.0 / v0[i0];
- break;
- }
-#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- v0[i0] = 1.0 / v0[i0];
- break;
- }
- case scm_tc7_cvect:
- {
- register double d;
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- {
- d = v0[i0][0] * v0[i0][0] + v0[i0][1] * v0[i0][1];
- v0[i0][0] /= d;
- v0[i0][1] /= -d;
- }
- break;
- }
-#endif /* SCM_FLOATS */
- }
- }
- else
- {
- SCM ra1 = SCM_CAR (ras);
- scm_sizet i1 = SCM_ARRAY_BASE (ra1);
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
- {
- default:
- {
- SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
- break;
- }
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- float *v1 = (float *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] /= v1[i1];)
- break;
- }
-#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- double *v1 = (double *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] /= v1[i1];)
- break;
- }
- case scm_tc7_cvect:
- {
- register double d, r;
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
- double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- d = v1[i1][0] * v1[i1][0] + v1[i1][1] * v1[i1][1];
- r = (v0[i0][0] * v1[i1][0] + v0[i0][1] * v1[i1][1]) / d;
- v0[i0][1] = (v0[i0][1] * v1[i1][0] - v0[i0][0] * v1[i1][1]) / d;
- v0[i0][0] = r;
- }
- )
- break;
- }
-#endif /* SCM_FLOATS */
- }
- }
- return 1;
-}
-
-
-int
-scm_array_identity (dst, src)
- SCM src;
- SCM dst;
-{
- return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
-}
-
-
-
-static int ramap SCM_P ((SCM ra0, SCM proc, SCM ras));
-
-static int
-ramap (ra0, proc, ras)
- SCM ra0;
- SCM proc;
- SCM ras;
-{
- long i = SCM_ARRAY_DIMS (ra0)->lbnd;
- long inc = SCM_ARRAY_DIMS (ra0)->inc;
- long n = SCM_ARRAY_DIMS (ra0)->ubnd;
- long base = SCM_ARRAY_BASE (ra0) - i * inc;
- ra0 = SCM_ARRAY_V (ra0);
- if SCM_NULLP
- (ras)
- for (; i <= n; i++)
- scm_array_set_x (ra0, scm_apply (proc, SCM_EOL, SCM_EOL), SCM_MAKINUM (i * inc + base));
- else
- {
- SCM ra1 = SCM_CAR (ras);
- SCM args, *ve = &ras;
- scm_sizet k, i1 = SCM_ARRAY_BASE (ra1);
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if SCM_NULLP
- (ras)
- ras = scm_nullvect;
- else
- {
- ras = scm_vector (ras);
- ve = SCM_VELTS (ras);
- }
- for (; i <= n; i++, i1 += inc1)
- {
- args = SCM_EOL;
- for (k = SCM_LENGTH (ras); k--;)
- args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args);
- args = scm_cons (scm_cvref (ra1, i1, SCM_UNDEFINED), args);
- scm_array_set_x (ra0, scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i * inc + base));
- }
- }
- return 1;
-}
-
-
-static int ramap_cxr SCM_P ((SCM ra0, SCM proc, SCM ras));
-
-static int
-ramap_cxr (ra0, proc, ras)
- SCM ra0;
- SCM proc;
- SCM ras;
-{
- SCM ra1 = SCM_CAR (ras);
- SCM e1 = SCM_UNDEFINED;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra1)->lbnd + 1;
- ra0 = SCM_ARRAY_V (ra0);
- ra1 = SCM_ARRAY_V (ra1);
- switch SCM_TYP7
- (ra0)
- {
- default:
- gencase:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0));
- break;
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *dst = (float *) SCM_VELTS (ra0);
- switch SCM_TYP7
- (ra1)
- {
- default:
- goto gencase;
- case scm_tc7_fvect:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- dst[i0] = SCM_DSUBRF (proc) ((double) ((float *) SCM_VELTS (ra1))[i1]);
- break;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]);
- break;
- }
- break;
- }
-#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *dst = (double *) SCM_VELTS (ra0);
- switch SCM_TYP7
- (ra1)
- {
- default:
- goto gencase;
- case scm_tc7_dvect:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- dst[i0] = SCM_DSUBRF (proc) (((double *) SCM_VELTS (ra1))[i1]);
- break;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]);
- break;
- }
- break;
- }
-#endif /* SCM_FLOATS */
- }
- return 1;
-}
-
-
-
-static int ramap_rp SCM_P ((SCM ra0, SCM proc, SCM ras));
-
-static int
-ramap_rp (ra0, proc, ras)
- SCM ra0;
- SCM proc;
- SCM ras;
-{
- SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
- SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
- long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1), i2 = SCM_ARRAY_BASE (ra2);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- long inc2 = SCM_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- ra1 = SCM_ARRAY_V (ra1);
- ra2 = SCM_ARRAY_V (ra2);
- switch (SCM_TYP7 (ra1) == SCM_TYP7 (ra2) ? SCM_TYP7 (ra1) : 0)
- {
- default:
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- if SCM_FALSEP
- (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))
- BVE_CLR (ra0, i0);
- break;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- {
- if SCM_FALSEP
- (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]),
- SCM_MAKINUM (SCM_VELTS (ra2)[i2])))
- BVE_CLR (ra0, i0);
- }
- break;
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- SCM a1 = scm_makflo (1.0), a2 = scm_makflo (1.0);
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- {
- SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1];
- SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2];
- if SCM_FALSEP
- (SCM_SUBRF (proc) (a1, a2))
- BVE_CLR (ra0, i0);
- }
- break;
- }
-#endif /*SCM_SINGLES*/
- case scm_tc7_dvect:
- {
- SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0);
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- {
- SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1];
- SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2];
- if SCM_FALSEP
- (SCM_SUBRF (proc) (a1, a2))
- BVE_CLR (ra0, i0);
- }
- break;
- }
- case scm_tc7_cvect:
- {
- SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0);
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if BVE_REF
- (ra0, i0)
- {
- SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1];
- SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1];
- SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2];
- SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1];
- if SCM_FALSEP
- (SCM_SUBRF (proc) (a1, a2))
- BVE_CLR (ra0, i0);
- }
- break;
- }
-#endif /*SCM_FLOATS*/
- }
- return 1;
-}
-
-
-
-static int ramap_1 SCM_P ((SCM ra0, SCM proc, SCM ras));
-
-static int
-ramap_1 (ra0, proc, ras)
- SCM ra0;
- SCM proc;
- SCM ras;
-{
- SCM ra1 = SCM_CAR (ras);
- SCM e1 = SCM_UNDEFINED;
- long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- ra1 = SCM_ARRAY_V (ra1);
- if (scm_tc7_vector == SCM_TYP7 (ra0))
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED)), SCM_MAKINUM (i0));
- else
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
- return 1;
-}
-
-
-
-static int ramap_2o SCM_P ((SCM ra0, SCM proc, SCM ras));
-
-static int
-ramap_2o (ra0, proc, ras)
- SCM ra0;
- SCM proc;
- SCM ras;
-{
- SCM ra1 = SCM_CAR (ras);
- SCM e1 = SCM_UNDEFINED;
- long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0), i1 = SCM_ARRAY_BASE (ra1);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc, inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- ra1 = SCM_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if SCM_NULLP
- (ras)
- {
- if (scm_tc7_vector == SCM_TYP7 (ra0))
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED),
- SCM_MAKINUM (i0));
- else
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED),
- SCM_MAKINUM (i0));
- }
- else
- {
- SCM ra2 = SCM_CAR (ras);
- SCM e2 = SCM_UNDEFINED;
- scm_sizet i2 = SCM_ARRAY_BASE (ra2);
- long inc2 = SCM_ARRAY_DIMS (ra2)->inc;
- ra2 = SCM_ARRAY_V (ra2);
- if (scm_tc7_vector == SCM_TYP7 (ra0))
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- scm_array_set_x (ra0,
- SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)),
- SCM_MAKINUM (i0));
- else
- for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- scm_array_set_x (ra0,
- SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)),
- SCM_MAKINUM (i0));
- }
- return 1;
-}
-
-
-
-static int ramap_a SCM_P ((SCM ra0, SCM proc, SCM ras));
-
-static int
-ramap_a (ra0, proc, ras)
- SCM ra0;
- SCM proc;
- SCM ras;
-{
- SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
- long n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- if SCM_NULLP
- (ras)
- for (; n-- > 0; i0 += inc0)
- scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
- else
- {
- SCM ra1 = SCM_CAR (ras);
- scm_sizet i1 = SCM_ARRAY_BASE (ra1);
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_ARRAY_V (ra1);
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
- SCM_MAKINUM (i0));
- }
- return 1;
-}
-
-SCM_PROC(s_serial_array_map, "serial-array-map", 2, 0, 1, scm_array_map);
-SCM_PROC(s_array_map, "array-map", 2, 0, 1, scm_array_map);
-
-SCM
-scm_array_map (ra0, proc, lra)
- SCM ra0;
- SCM proc;
- SCM lra;
-{
- SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_map);
- switch (SCM_TYP7 (proc))
- {
- default:
- gencase:
- scm_ramapc (ramap, proc, ra0, lra, s_array_map);
- return SCM_UNSPECIFIED;
- case scm_tc7_subr_1:
- scm_ramapc (ramap_1, proc, ra0, lra, s_array_map);
- return SCM_UNSPECIFIED;
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map);
- return SCM_UNSPECIFIED;
- case scm_tc7_cxr:
- if (!SCM_SUBRF (proc))
- goto gencase;
- scm_ramapc (ramap_cxr, proc, ra0, lra, s_array_map);
- return SCM_UNSPECIFIED;
- case scm_tc7_rpsubr:
- {
- ra_iproc *p;
- if (SCM_FALSEP (scm_array_p (ra0, SCM_BOOL_T)))
- goto gencase;
- scm_array_fill_x (ra0, SCM_BOOL_T);
- for (p = ra_rpsubrs; p->name; p++)
- if (proc == p->sproc)
- {
- while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
- {
- scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map);
- lra = SCM_CDR (lra);
- }
- return SCM_UNSPECIFIED;
- }
- while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
- {
- scm_ramapc (ramap_rp, proc, ra0, lra, s_array_map);
- lra = SCM_CDR (lra);
- }
- return SCM_UNSPECIFIED;
- }
- case scm_tc7_asubr:
- if SCM_NULLP
- (lra)
- {
- SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
- if SCM_INUMP
- (fill)
- {
- prot = scm_array_prototype (ra0);
- if (SCM_NIMP (prot) && SCM_INEXP (prot))
- fill = scm_makdbl ((double) SCM_INUM (fill), 0.0);
- }
-
- scm_array_fill_x (ra0, fill);
- }
- else
- {
- SCM tail, ra1 = SCM_CAR (lra);
- SCM v0 = (SCM_NIMP (ra0) && SCM_ARRAYP (ra0) ? SCM_ARRAY_V (ra0) : ra0);
- ra_iproc *p;
- /* Check to see if order might matter.
- This might be an argument for a separate
- SERIAL-ARRAY-MAP! */
- if (v0 == ra1 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
- if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
- goto gencase;
- for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail))
- {
- ra1 = SCM_CAR (tail);
- if (v0 == ra1 || (SCM_NIMP (ra1) && SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
- goto gencase;
- }
- for (p = ra_asubrs; p->name; p++)
- if (proc == p->sproc)
- {
- if (ra0 != SCM_CAR (lra))
- scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), s_array_map);
- lra = SCM_CDR (lra);
- while (1)
- {
- scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, s_array_map);
- if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
- return SCM_UNSPECIFIED;
- lra = SCM_CDR (lra);
- }
- }
- scm_ramapc (ramap_2o, proc, ra0, lra, s_array_map);
- lra = SCM_CDR (lra);
- if SCM_NIMP
- (lra)
- for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
- scm_ramapc (ramap_a, proc, ra0, lra, s_array_map);
- }
- return SCM_UNSPECIFIED;
- }
-}
-
-
-static int rafe SCM_P ((SCM ra0, SCM proc, SCM ras));
-
-static int
-rafe (ra0, proc, ras)
- SCM ra0;
- SCM proc;
- SCM ras;
-{
- long i = SCM_ARRAY_DIMS (ra0)->lbnd;
- scm_sizet i0 = SCM_ARRAY_BASE (ra0);
- long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
- long n = SCM_ARRAY_DIMS (ra0)->ubnd;
- ra0 = SCM_ARRAY_V (ra0);
- if SCM_NULLP
- (ras)
- for (; i <= n; i++, i0 += inc0)
- scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), scm_listofnull);
- else
- {
- SCM ra1 = SCM_CAR (ras);
- SCM args, *ve = &ras;
- scm_sizet k, i1 = SCM_ARRAY_BASE (ra1);
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_ARRAY_V (ra1);
- ras = SCM_CDR (ras);
- if SCM_NULLP
- (ras)
- ras = scm_nullvect;
- else
- {
- ras = scm_vector (ras);
- ve = SCM_VELTS (ras);
- }
- for (; i <= n; i++, i0 += inc0, i1 += inc1)
- {
- args = SCM_EOL;
- for (k = SCM_LENGTH (ras); k--;)
- args = scm_cons (scm_uniform_vector_ref (ve[k], SCM_MAKINUM (i)), args);
- args = scm_cons2 (scm_cvref (ra0, i0, SCM_UNDEFINED), scm_cvref (ra1, i1, SCM_UNDEFINED), args);
- scm_apply (proc, args, SCM_EOL);
- }
- }
- return 1;
-}
-
-
-SCM_PROC(s_array_for_each, "array-for-each", 2, 0, 1, scm_array_for_each);
-
-SCM
-scm_array_for_each (proc, ra0, lra)
- SCM proc;
- SCM ra0;
- SCM lra;
-{
- SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG1, s_array_for_each);
- scm_ramapc (rafe, proc, ra0, lra, s_array_for_each);
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC(s_array_index_map_x, "array-index-map!", 2, 0, 0, scm_array_index_map_x);
-
-SCM
-scm_array_index_map_x (ra, proc)
- SCM ra;
- SCM proc;
-{
- scm_sizet i;
- SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_array_index_map_x);
- SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc), proc, SCM_ARG2, s_array_index_map_x);
- switch SCM_TYP7
- (ra)
- {
- default:
- badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_index_map_x);
- case scm_tc7_vector:
- {
- SCM *ve = SCM_VELTS (ra);
- for (i = 0; i < SCM_LENGTH (ra); i++)
- ve[i] = scm_apply (proc, SCM_MAKINUM (i), scm_listofnull);
- return SCM_UNSPECIFIED;
- }
- case scm_tc7_string:
- case scm_tc7_bvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- for (i = 0; i < SCM_LENGTH (ra); i++)
- scm_array_set_x (ra, scm_apply (proc, SCM_MAKINUM (i), scm_listofnull), SCM_MAKINUM (i));
- return SCM_UNSPECIFIED;
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
- {
- SCM args = SCM_EOL;
- SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_MAKINUM (-1L));
- long *vinds = SCM_VELTS (inds);
- int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1;
- for (k = 0; k <= kmax; k++)
- vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd;
- k = kmax;
- do
- {
- if (k == kmax)
- {
- vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd;
- i = cind (ra, inds);
- for (; vinds[k] <= SCM_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
- {
- for (j = kmax + 1, args = SCM_EOL; j--;)
- args = scm_cons (SCM_MAKINUM (vinds[j]), args);
- scm_array_set_x (SCM_ARRAY_V (ra), scm_apply (proc, args, SCM_EOL), SCM_MAKINUM (i));
- i += SCM_ARRAY_DIMS (ra)[k].inc;
- }
- k--;
- continue;
- }
- if (vinds[k] < SCM_ARRAY_DIMS (ra)[k].ubnd)
- {
- vinds[k]++;
- k++;
- continue;
- }
- vinds[k] = SCM_ARRAY_DIMS (ra)[k].lbnd - 1;
- k--;
- }
- while (k >= 0);
- return SCM_UNSPECIFIED;
- }
- }
-}
-
-
-static int raeql_1 SCM_P ((SCM ra0, SCM as_equal, SCM ra1));
-
-static int
-raeql_1 (ra0, as_equal, ra1)
- SCM ra0;
- SCM as_equal;
- SCM ra1;
-{
- SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
- scm_sizet i0 = 0, i1 = 0;
- long inc0 = 1, inc1 = 1;
- scm_sizet n = SCM_LENGTH (ra0);
- ra1 = SCM_CAR (ra1);
- if SCM_ARRAYP
- (ra0)
- {
- n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- i0 = SCM_ARRAY_BASE (ra0);
- inc0 = SCM_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- }
- if SCM_ARRAYP
- (ra1)
- {
- i1 = SCM_ARRAY_BASE (ra1);
- inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_ARRAY_V (ra1);
- }
- switch SCM_TYP7
- (ra0)
- {
- case scm_tc7_vector:
- default:
- for (; n--; i0 += inc0, i1 += inc1)
- {
- if SCM_FALSEP
- (as_equal)
- {
- if SCM_FALSEP
- (scm_array_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))
- return 0;
- }
- else if SCM_FALSEP
- (scm_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))
- return 0;
- }
- return 1;
- case scm_tc7_string:
- {
- char *v0 = SCM_CHARS (ra0) + i0;
- char *v1 = SCM_CHARS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- if (*v0 != *v1)
- return 0;
- return 1;
- }
- case scm_tc7_bvect:
- for (; n--; i0 += inc0, i1 += inc1)
- if (BVE_REF (ra0, i0) != BVE_REF (ra1, i1))
- return 0;
- return 1;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- {
- long *v0 = (long *) SCM_VELTS (ra0) + i0;
- long *v1 = (long *) SCM_VELTS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- if (*v0 != *v1)
- return 0;
- return 1;
- }
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0) + i0;
- float *v1 = (float *) SCM_VELTS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- if (*v0 != *v1)
- return 0;
- return 1;
- }
-#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0) + i0;
- double *v1 = (double *) SCM_VELTS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- if (*v0 != *v1)
- return 0;
- return 1;
- }
- case scm_tc7_cvect:
- {
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0) + i0;
- double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- {
- if ((*v0)[0] != (*v1)[0])
- return 0;
- if ((*v0)[1] != (*v1)[1])
- return 0;
- }
- return 1;
- }
-#endif /* SCM_FLOATS */
- }
-}
-
-
-
-static int raeql SCM_P ((SCM ra0, SCM as_equal, SCM ra1));
-
-static int
-raeql (ra0, as_equal, ra1)
- SCM ra0;
- SCM as_equal;
- SCM ra1;
-{
- SCM v0 = ra0, v1 = ra1;
- scm_array_dim dim0, dim1;
- scm_array_dim *s0 = &dim0, *s1 = &dim1;
- scm_sizet bas0 = 0, bas1 = 0;
- int k, unroll = 1, vlen = 1, ndim = 1;
- if SCM_ARRAYP
- (ra0)
- {
- ndim = SCM_ARRAY_NDIM (ra0);
- s0 = SCM_ARRAY_DIMS (ra0);
- bas0 = SCM_ARRAY_BASE (ra0);
- v0 = SCM_ARRAY_V (ra0);
- }
- else
- {
- s0->inc = 1;
- s0->lbnd = 0;
- s0->ubnd = SCM_LENGTH (v0) - 1;
- unroll = 0;
- }
- if SCM_ARRAYP
- (ra1)
- {
- if (ndim != SCM_ARRAY_NDIM (ra1))
- return 0;
- s1 = SCM_ARRAY_DIMS (ra1);
- bas1 = SCM_ARRAY_BASE (ra1);
- v1 = SCM_ARRAY_V (ra1);
- }
- else
- {
- if (1 != ndim)
- return SCM_BOOL_F;
- s1->inc = 1;
- s1->lbnd = 0;
- s1->ubnd = SCM_LENGTH (v1) - 1;
- unroll = 0;
- }
- if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
- return 0;
- for (k = ndim; k--;)
- {
- if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd)
- return 0;
- if (unroll)
- {
- unroll = (s0[k].inc == s1[k].inc);
- vlen *= s0[k].ubnd - s1[k].lbnd + 1;
- }
- }
- if (unroll && bas0 == bas1 && v0 == v1)
- return SCM_BOOL_T;
- return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
-}
-
-
-SCM
-scm_raequal (ra0, ra1)
- SCM ra0;
- SCM ra1;
-{
- return (raeql (ra0, SCM_BOOL_T, ra1) ? SCM_BOOL_T : SCM_BOOL_F);
-}
-
-static char s_array_equal_p[] = "array-equal?";
-
-
-SCM
-scm_array_equal_p (ra0, ra1)
- SCM ra0;
- SCM ra1;
-{
- if (SCM_IMP (ra0) || SCM_IMP (ra1))
- callequal:return scm_equal_p (ra0, ra1);
- switch SCM_TYP7
- (ra0)
- {
- default:
- goto callequal;
- case scm_tc7_bvect:
- case scm_tc7_string:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_vector:
- break;
- case scm_tc7_smob:
- if (!SCM_ARRAYP (ra0))
- goto callequal;
- }
- switch SCM_TYP7
- (ra1)
- {
- default:
- goto callequal;
- case scm_tc7_bvect:
- case scm_tc7_string:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_vector:
- break;
- case scm_tc7_smob:
- if (!SCM_ARRAYP (ra1))
- goto callequal;
- }
- return (raeql (ra0, SCM_BOOL_F, ra1) ? SCM_BOOL_T : SCM_BOOL_F);
-}
-
-
-
-
-/* These tables are a kluge that will not scale well when more
- * vectorized subrs are added. It is tempting to steal some bits from
- * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
- * offset into a table of vectorized subrs.
- */
-
-static ra_iproc ra_rpsubrs[] =
-{
- {"=", SCM_UNDEFINED, scm_ra_eqp},
- {"<", SCM_UNDEFINED, scm_ra_lessp},
- {"<=", SCM_UNDEFINED, scm_ra_leqp},
- {">", SCM_UNDEFINED, scm_ra_grp},
- {">=", SCM_UNDEFINED, scm_ra_greqp},
- {0, 0, 0}
-};
-
-static ra_iproc ra_asubrs[] =
-{
- {"+", SCM_UNDEFINED, scm_ra_sum},
- {"-", SCM_UNDEFINED, scm_ra_difference},
- {"*", SCM_UNDEFINED, scm_ra_product},
- {"/", SCM_UNDEFINED, scm_ra_divide},
- {0, 0, 0}
-};
-
-static void
-init_raprocs (subra)
- ra_iproc *subra;
-{
- for (; subra->name; subra++)
- subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name)));
-}
-
-
-void
-scm_init_ramap ()
-{
- init_raprocs (ra_rpsubrs);
- init_raprocs (ra_asubrs);
- scm_make_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
- scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp = scm_raequal;
-#include "ramap.x"
- scm_add_feature (s_array_for_each);
-}
-
-#endif /* ARRAYS */
diff --git a/libguile/ramap.h b/libguile/ramap.h
deleted file mode 100644
index da4ec2691..000000000
--- a/libguile/ramap.h
+++ /dev/null
@@ -1,73 +0,0 @@
-/* classes: h_files */
-
-#ifndef RAMAPH
-#define RAMAPH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-extern int scm_ra_matchp SCM_P ((SCM ra0, SCM ras));
-extern int scm_ramapc SCM_P ((int (*cproc) (), SCM data, SCM ra0, SCM lra, char *what));
-extern int scm_array_fill_int SCM_P ((SCM ra, SCM fill, SCM ignore));
-extern SCM scm_array_fill_x SCM_P ((SCM ra, SCM fill));
-extern SCM scm_array_copy_x SCM_P ((SCM src, SCM dst));
-extern int scm_ra_eqp SCM_P ((SCM ra0, SCM ras));
-extern int scm_ra_lessp SCM_P ((SCM ra0, SCM ras));
-extern int scm_ra_leqp SCM_P ((SCM ra0, SCM ras));
-extern int scm_ra_grp SCM_P ((SCM ra0, SCM ras));
-extern int scm_ra_greqp SCM_P ((SCM ra0, SCM ras));
-extern int scm_ra_sum SCM_P ((SCM ra0, SCM ras));
-extern int scm_ra_difference SCM_P ((SCM ra0, SCM ras));
-extern int scm_ra_product SCM_P ((SCM ra0, SCM ras));
-extern int scm_ra_divide SCM_P ((SCM ra0, SCM ras));
-extern int scm_array_identity SCM_P ((SCM src, SCM dst));
-extern SCM scm_array_map SCM_P ((SCM ra0, SCM proc, SCM lra));
-extern SCM scm_array_for_each SCM_P ((SCM proc, SCM ra0, SCM lra));
-extern SCM scm_array_index_map_x SCM_P ((SCM ra, SCM proc));
-extern SCM scm_raequal SCM_P ((SCM ra0, SCM ra1));
-extern SCM scm_array_equal_p SCM_P ((SCM ra0, SCM ra1));
-extern void scm_init_ramap SCM_P ((void));
-
-#endif /* RAMAPH */
diff --git a/libguile/read.c b/libguile/read.c
deleted file mode 100644
index 48badf976..000000000
--- a/libguile/read.c
+++ /dev/null
@@ -1,768 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "extchrs.h"
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-#include "genio.h"
-#include "eval.h"
-#include "unif.h"
-#include "mbstrings.h"
-#include "kw.h"
-#include "alist.h"
-#include "srcprop.h"
-#include "hashtab.h"
-#include "hash.h"
-
-#include "read.h"
-
-
-
-#define default_case_i 0
-
-
-
-scm_option scm_read_opts[] = {
- { SCM_OPTION_BOOLEAN, "copy", 0,
- "Copy source code expressions." },
- { SCM_OPTION_BOOLEAN, "positions", 0,
- "Record positions of source code expressions." }
-};
-
-SCM_PROC (s_read_options, "read-options-interface", 0, 1, 0, scm_read_options);
-
-SCM
-scm_read_options (setting)
- SCM setting;
-{
- SCM ans = scm_options (setting,
- scm_read_opts,
- SCM_N_READ_OPTIONS,
- s_read_options);
- if (SCM_COPY_SOURCE_P)
- SCM_RECORD_POSITIONS_P = 1;
- return ans;
-}
-
-SCM_PROC (s_read, "read", 0, 3, 0, scm_read);
-
-SCM
-scm_read (port, case_insensitive_p, sharp)
- SCM port;
- SCM case_insensitive_p;
- SCM sharp;
-{
- int c;
- SCM tok_buf, copy;
- int case_i;
-
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINPORTP (port),
- port,
- SCM_ARG1,
- s_read);
-
- case_i = (SCM_UNBNDP (case_insensitive_p)
- ? default_case_i
- : (case_insensitive_p == SCM_BOOL_F));
-
- if (SCM_UNBNDP (sharp))
- sharp = SCM_BOOL_F;
-
- c = scm_flush_ws (port, (char *) NULL);
- if (EOF == c)
- return SCM_EOF_VAL;
- scm_gen_ungetc (c, port);
-
- tok_buf = scm_makstr (30L, 0);
- return scm_lreadr (&tok_buf, port, case_i, sharp, &copy);
-}
-
-
-
-char *
-scm_grow_tok_buf (tok_buf)
- SCM * tok_buf;
-{
- scm_vector_set_length_x (*tok_buf, SCM_MAKINUM (2 * SCM_LENGTH (*tok_buf)));
- return SCM_CHARS (*tok_buf);
-}
-
-
-
-int
-scm_flush_ws (port, eoferr)
- SCM port;
- char *eoferr;
-{
- register int c;
- while (1)
- switch (c = scm_gen_getc (port))
- {
- case EOF:
- goteof:
- if (eoferr)
- scm_wta (SCM_UNDEFINED, "end of file in ", eoferr);
- return c;
- case ';':
- lp:
- switch (c = scm_gen_getc (port))
- {
- case EOF:
- goto goteof;
- default:
- goto lp;
- case SCM_LINE_INCREMENTORS:
- break;
- }
- break;
- case SCM_LINE_INCREMENTORS:
- case SCM_SINGLE_SPACES:
- case '\t':
- break;
- default:
- return c;
- }
-}
-
-
-
-int
-scm_casei_streq (s1, s2)
- char * s1;
- char * s2;
-{
- while (*s1 && *s2)
- if (scm_downcase((int)*s1) != scm_downcase((int)*s2))
- return 0;
- else
- {
- ++s1;
- ++s2;
- }
- return !(*s1 || *s2);
-}
-
-
-/* recsexpr is used when recording expressions
- * constructed by read:sharp.
- */
-
-static SCM recsexpr SCM_P ((SCM obj, int line, int column, SCM filename));
-
-static SCM
-recsexpr (obj, line, column, filename)
- SCM obj;
- int line;
- int column;
- SCM filename;
-{
- if (SCM_IMP (obj) || SCM_NCONSP(obj))
- return obj;
- {
- SCM tmp = obj, copy;
- /* If this sexpr is visible in the read:sharp source, we want to
- keep that information, so only record non-constant cons cells
- which haven't previously been read by the reader. */
- if (SCM_FALSEP (scm_whash_lookup (scm_source_whash, obj)))
- {
- if (SCM_COPY_SOURCE_P)
- {
- copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
- SCM_UNDEFINED);
- while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp))
- {
- SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
- line,
- column,
- filename),
- SCM_UNDEFINED));
- copy = SCM_CDR (copy);
- }
- SCM_SETCDR (copy, tmp);
- }
- else
- {
- recsexpr (SCM_CAR (obj), line, column, filename);
- while (SCM_NIMP (tmp = SCM_CDR (tmp)) && SCM_CONSP (tmp))
- recsexpr (SCM_CAR (tmp), line, column, filename);
- copy = SCM_UNDEFINED;
- }
- scm_whash_insert (scm_source_whash,
- obj,
- scm_make_srcprops (line,
- column,
- filename,
- copy,
- SCM_EOL));
- }
- return obj;
- }
-}
-
-
-/* Consume an SCSH-style block comment. Assume that we've already
- read the initial `#!', and eat characters until the matching `!#'. */
-
-static void
-skip_scsh_block_comment (port)
- SCM port;
-{
- char last_c = '\0';
-
- for (;;)
- {
- int c = scm_gen_getc (port);
-
- if (c == EOF)
- scm_wta (SCM_UNDEFINED,
- "unterminated `#! ... !#' comment", "read");
- else if (c == '#' && last_c == '!')
- return;
-
- last_c = c;
- }
-}
-
-
-static char s_list[]="list";
-
-SCM
-scm_lreadr (tok_buf, port, case_i, sharp, copy)
- SCM *tok_buf;
- SCM port;
- int case_i;
- SCM sharp;
- SCM *copy;
-{
- int c;
- scm_sizet j;
- SCM p;
-
-tryagain:
- c = scm_flush_ws (port, s_read);
- switch (c)
- {
- case EOF:
- return SCM_EOF_VAL;
-
- case '(':
- return SCM_RECORD_POSITIONS_P
- ? scm_lreadrecparen (tok_buf, port, s_list, case_i, sharp, copy)
- : scm_lreadparen (tok_buf, port, s_list, case_i, sharp, copy);
- case ')':
- scm_wta (SCM_UNDEFINED, "unexpected \")\"", "read");
- goto tryagain;
-
- case '\'':
- p = scm_i_quote;
- goto recquote;
- case '`':
- p = scm_i_quasiquote;
- goto recquote;
- case ',':
- c = scm_gen_getc (port);
- if ('@' == c)
- p = scm_i_uq_splicing;
- else
- {
- scm_gen_ungetc (c, port);
- p = scm_i_unquote;
- }
- recquote:
- p = scm_cons2 (p,
- scm_lreadr (tok_buf, port, case_i, sharp, copy),
- SCM_EOL);
- if (SCM_RECORD_POSITIONS_P)
- scm_whash_insert (scm_source_whash,
- p,
- scm_make_srcprops (SCM_LINUM (port),
- SCM_COL (port) - 1,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? (*copy = scm_cons2 (SCM_CAR (p),
- SCM_CAR (SCM_CDR (p)),
- SCM_EOL))
- : SCM_UNDEFINED,
- SCM_EOL));
- return p;
- case '#':
- c = scm_gen_getc (port);
- switch (c)
- {
- case '(':
- p = scm_lreadparen (tok_buf, port, "vector", case_i, sharp, copy);
- return SCM_NULLP (p) ? scm_nullvect : scm_vector (p);
-
- case 't':
- case 'T':
- return SCM_BOOL_T;
- case 'f':
- case 'F':
- return SCM_BOOL_F;
-
- case 'b':
- case 'B':
- case 'o':
- case 'O':
- case 'd':
- case 'D':
- case 'x':
- case 'X':
- case 'i':
- case 'I':
- case 'e':
- case 'E':
- scm_gen_ungetc (c, port);
- c = '#';
- goto num;
-
- case '!':
- /* start of a shell script. Parse as a block comment,
- terminated by !#, just like SCSH. */
- skip_scsh_block_comment (port);
- goto tryagain;
-
- case '*':
- j = scm_read_token (c, tok_buf, port, case_i, 0);
- p = scm_istr2bve (SCM_CHARS (*tok_buf) + 1, (long) (j - 1));
- if (SCM_NFALSEP (p))
- return p;
- else
- goto unkshrp;
-
- case '{':
- j = scm_read_token (c, tok_buf, port, case_i, 1);
- p = scm_intern (SCM_CHARS (*tok_buf), j);
- if (SCM_PORT_REPRESENTATION (port) != scm_regular_port)
- scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T);
- return SCM_CAR (p);
-
- case '\\':
- c = scm_gen_getc (port);
- j = scm_read_token (c, tok_buf, port, case_i, 0);
- if (j == 1)
- return SCM_MAKICHR (c);
- if (c >= '0' && c < '8')
- {
- p = scm_istr2int (SCM_CHARS (*tok_buf), (long) j, 8);
- if (SCM_NFALSEP (p))
- return SCM_MAKICHR (SCM_INUM (p));
- }
- for (c = 0; c < scm_n_charnames; c++)
- if (scm_charnames[c]
- && (scm_casei_streq (scm_charnames[c], SCM_CHARS (*tok_buf))))
- return SCM_MAKICHR (scm_charnums[c]);
- scm_wta (SCM_UNDEFINED, "unknown # object: #\\", SCM_CHARS (*tok_buf));
-
-
- default:
- callshrp:
- if (SCM_NIMP (sharp))
- {
- int line = SCM_LINUM (port);
- int column = SCM_COL (port) - 2;
- SCM got;
- got = scm_apply (sharp,
- SCM_MAKICHR (c),
- scm_acons (port, SCM_EOL, SCM_EOL));
- if (SCM_UNSPECIFIED == got)
- goto unkshrp;
- if (SCM_RECORD_POSITIONS_P)
- return *copy = recsexpr (got, line, column,
- SCM_FILENAME (port));
- else
- return got;
- }
- unkshrp:scm_wta ((SCM) SCM_MAKICHR (c), "unknown # object", "");
- }
-
- case '"':
- j = 0;
- while ('"' != (c = scm_gen_getc (port)))
- {
- SCM_ASSERT (EOF != c, SCM_UNDEFINED, "end of file in ", "string");
-
- while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf))
- scm_grow_tok_buf (tok_buf);
-
- if (c == '\\')
- switch (c = scm_gen_getc (port))
- {
- case '\n':
- continue;
- case '0':
- c = '\0';
- break;
- case 'f':
- c = '\f';
- break;
- case 'n':
- c = '\n';
- break;
- case 'r':
- c = '\r';
- break;
- case 't':
- c = '\t';
- break;
- case 'a':
- c = '\007';
- break;
- case 'v':
- c = '\v';
- break;
- }
- if (SCM_PORT_REPRESENTATION(port) == scm_regular_port)
- {
- SCM_CHARS (*tok_buf)[j] = c;
- ++j;
- }
- else
- {
- int len;
- len = xwctomb (SCM_CHARS (*tok_buf) + j, c);
- if (len == 0)
- len = 1;
- SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read");
- j += len;
- }
- }
- if (j == 0)
- return scm_nullstr;
- SCM_CHARS (*tok_buf)[j] = 0;
- {
- SCM str;
- str = scm_makfromstr (SCM_CHARS (*tok_buf), j, 0);
- if (SCM_PORT_REPRESENTATION(port) != scm_regular_port)
- {
- SCM_SETLENGTH (str, SCM_LENGTH (str), scm_tc7_mb_string);
- }
- return str;
- }
-
- case'0':case '1':case '2':case '3':case '4':
- case '5':case '6':case '7':case '8':case '9':
- case '.':
- case '-':
- case '+':
- num:
- j = scm_read_token (c, tok_buf, port, case_i, 0);
- p = scm_istring2number (SCM_CHARS (*tok_buf), (long) j, 10L);
- if (SCM_NFALSEP (p))
- return p;
- if (c == '#')
- {
- if ((j == 2) && (scm_gen_getc (port) == '('))
- {
- scm_gen_ungetc ('(', port);
- c = SCM_CHARS (*tok_buf)[1];
- goto callshrp;
- }
- scm_wta (SCM_UNDEFINED, "unknown # object", SCM_CHARS (*tok_buf));
- }
- goto tok;
-
- case ':':
- j = scm_read_token ('-', tok_buf, port, case_i, 0);
- p = scm_intern (SCM_CHARS (*tok_buf), j);
- if (SCM_PORT_REPRESENTATION (port) != scm_regular_port)
- scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T);
- return scm_make_keyword_from_dash_symbol (SCM_CAR (p));
-
- default:
- j = scm_read_token (c, tok_buf, port, case_i, 0);
- /* fallthrough */
-
- tok:
- p = scm_intern (SCM_CHARS (*tok_buf), j);
- if (SCM_PORT_REPRESENTATION (port) != scm_regular_port)
- scm_set_symbol_multi_byte_x (SCM_CAR (p), SCM_BOOL_T);
- return SCM_CAR (p);
- }
-}
-
-#ifdef _UNICOS
-_Pragma ("noopt"); /* # pragma _CRI noopt */
-#endif
-
-scm_sizet
-scm_read_token (ic, tok_buf, port, case_i, weird)
- int ic;
- SCM *tok_buf;
- SCM port;
- int case_i;
- int weird;
-{
- register scm_sizet j;
- register int c;
- register char *p;
-
- c = ic;
- p = SCM_CHARS (*tok_buf);
-
- if (weird)
- j = 0;
- else
- {
- j = 0;
- while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf))
- p = scm_grow_tok_buf (tok_buf);
- if (SCM_PORT_REPRESENTATION(port) == scm_regular_port)
- {
- p[j] = c;
- ++j;
- }
- else
- {
- int len;
- len = xwctomb (p + j, c);
- if (len == 0)
- len = 1;
- SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read");
- j += len;
- }
- }
-
- while (1)
- {
- while (j + sizeof(xwchar_t) + XMB_CUR_MAX >= SCM_LENGTH (*tok_buf))
- p = scm_grow_tok_buf (tok_buf);
- c = scm_gen_getc (port);
- switch (c)
- {
- case '(':
- case ')':
- case '"':
- case ';':
- case SCM_WHITE_SPACES:
- case SCM_LINE_INCREMENTORS:
- if (weird)
- goto default_case;
-
- scm_gen_ungetc (c, port);
- case EOF:
- eof_case:
- p[j] = 0;
- return j;
- case '\\':
- if (!weird)
- goto default_case;
- else
- {
- c = scm_gen_getc (port);
- if (c == EOF)
- goto eof_case;
- else
- goto default_case;
- }
- case '}':
- if (!weird)
- goto default_case;
-
- c = scm_gen_getc (port);
- if (c == '#')
- {
- p[j] = 0;
- return j;
- }
- else
- {
- scm_gen_ungetc (c, port);
- c = '}';
- goto default_case;
- }
-
- default:
- default_case:
- {
- c = (case_i ? scm_downcase(c) : c);
- if (SCM_PORT_REPRESENTATION(port) == scm_regular_port)
- {
- p[j] = c;
- ++j;
- }
- else
- {
- int len;
- len = xwctomb (p + j, c);
- if (len == 0)
- len = 1;
- SCM_ASSERT (len > 0, SCM_MAKINUM (c), "bogus char", "read");
- j += len;
- }
- }
-
- }
- }
-}
-
-#ifdef _UNICOS
-_Pragma ("opt"); /* # pragma _CRI opt */
-#endif
-
-SCM
-scm_lreadparen (tok_buf, port, name, case_i, sharp, copy)
- SCM *tok_buf;
- SCM port;
- char *name;
- int case_i;
- SCM sharp;
- SCM *copy;
-{
- SCM tmp;
- SCM tl;
- SCM ans;
- int c;
-
- c = scm_flush_ws (port, name);
- if (')' == c)
- return SCM_EOL;
- scm_gen_ungetc (c, port);
- if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)))
- {
- ans = scm_lreadr (tok_buf, port, case_i, sharp, copy);
- closeit:
- if (')' != (c = scm_flush_ws (port, name)))
- scm_wta (SCM_UNDEFINED, "missing close paren", "");
- return ans;
- }
- ans = tl = scm_cons (tmp, SCM_EOL);
- while (')' != (c = scm_flush_ws (port, name)))
- {
- scm_gen_ungetc (c, port);
- if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)))
- {
- SCM_SETCDR (tl, scm_lreadr (tok_buf, port, case_i, sharp, copy));
- goto closeit;
- }
- SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL));
- tl = SCM_CDR (tl);
- }
- return ans;
-}
-
-
-SCM
-scm_lreadrecparen (tok_buf, port, name, case_i, sharp, copy)
- SCM *tok_buf;
- SCM port;
- char *name;
- int case_i;
- SCM sharp;
- SCM *copy;
-{
- register int c;
- register SCM tmp;
- register SCM tl, tl2 = SCM_EOL;
- SCM ans, ans2 = SCM_EOL;
- /* Need to capture line and column numbers here. */
- int line = SCM_LINUM (port);
- int column = SCM_COL (port) - 1;
-
- c = scm_flush_ws (port, name);
- if (')' == c)
- return SCM_EOL;
- scm_gen_ungetc (c, port);
- if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)))
- {
- ans = scm_lreadr (tok_buf, port, case_i, sharp, copy);
- if (')' != (c = scm_flush_ws (port, name)))
- scm_wta (SCM_UNDEFINED, "missing close paren", "");
- return ans;
- }
- /* Build the head of the list structure. */
- ans = tl = scm_cons (tmp, SCM_EOL);
- if (SCM_COPY_SOURCE_P)
- ans2 = tl2 = scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
- ? *copy
- : tmp,
- SCM_EOL);
- while (')' != (c = scm_flush_ws (port, name)))
- {
- scm_gen_ungetc (c, port);
- if (scm_i_dot == (tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy)))
- {
- SCM_SETCDR (tl, tmp = scm_lreadr (tok_buf, port, case_i, sharp, copy));
- if (SCM_COPY_SOURCE_P)
- SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
- ? *copy
- : tmp,
- SCM_EOL));
- if (')' != (c = scm_flush_ws (port, name)))
- scm_wta (SCM_UNDEFINED, "missing close paren", "");
- goto exit;
- }
- tl = SCM_SETCDR (tl, scm_cons (tmp, SCM_EOL));
- if (SCM_COPY_SOURCE_P)
- tl2 = SCM_SETCDR (tl2, scm_cons (SCM_NIMP (tmp) && SCM_CONSP (tmp)
- ? *copy
- : tmp,
- SCM_EOL));
- }
-exit:
- scm_whash_insert (scm_source_whash,
- ans,
- scm_make_srcprops (line,
- column,
- SCM_FILENAME (port),
- SCM_COPY_SOURCE_P
- ? *copy = ans2
- : SCM_UNDEFINED,
- SCM_EOL));
- return ans;
-}
-
-
-
-
-
-
-void
-scm_init_read ()
-{
- scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
-#include "read.x"
-}
diff --git a/libguile/read.h b/libguile/read.h
deleted file mode 100644
index 8eef1ed24..000000000
--- a/libguile/read.h
+++ /dev/null
@@ -1,89 +0,0 @@
-/* classes: h_files */
-
-#ifndef READH
-#define READH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-#include "libguile/options.h"
-
-
-/* SCM_LINE_INCREMENTORS are the characters which cause the line count to
- * be incremented for the purposes of error reporting. This feature
- * is only used for scheme code loaded from files.
- *
- * SCM_WHITE_SPACES are other characters which should be treated like spaces
- * in programs.
- */
-
-#define SCM_LINE_INCREMENTORS '\n'
-
-#ifdef MSDOS
-# define SCM_SINGLE_SPACES ' ':case '\r':case '\f': case 26
-#else
-# define SCM_SINGLE_SPACES ' ':case '\r':case '\f'
-#endif
-
-#define SCM_WHITE_SPACES SCM_SINGLE_SPACES: case '\t'
-
-extern scm_option scm_read_opts[];
-
-#define SCM_COPY_SOURCE_P scm_read_opts[0].val
-#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val
-#define SCM_N_READ_OPTIONS 2
-
-
-
-extern SCM scm_read_options SCM_P ((SCM setting));
-extern SCM scm_read SCM_P ((SCM port, SCM casep, SCM sharp));
-extern char * scm_grow_tok_buf SCM_P ((SCM * tok_buf));
-extern int scm_flush_ws SCM_P ((SCM port, char *eoferr));
-extern int scm_casei_streq SCM_P ((char * s1, char * s2));
-extern SCM scm_lreadr SCM_P ((SCM * tok_buf, SCM port, int case_i, SCM sharp, SCM *copy));
-extern scm_sizet scm_read_token SCM_P ((int ic, SCM * tok_buf, SCM port, int case_i, int weird));
-extern SCM scm_lreadparen SCM_P ((SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy));
-extern SCM scm_lreadrecparen SCM_P ((SCM * tok_buf, SCM port, char *name, int case_i, SCM sharp, SCM *copy));
-extern void scm_init_read SCM_P ((void));
-
-#endif /* READH */
diff --git a/libguile/root.c b/libguile/root.c
deleted file mode 100644
index b79e7b72b..000000000
--- a/libguile/root.c
+++ /dev/null
@@ -1,378 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "stackchk.h"
-#include "dynwind.h"
-#include "eval.h"
-#include "genio.h"
-#include "smob.h"
-#include "pairs.h"
-#include "throw.h"
-
-#include "root.h"
-
-
-SCM scm_sys_protects[SCM_NUM_PROTECTS];
-
-long scm_tc16_root;
-
-#ifndef USE_THREADS
-struct scm_root_state *scm_root;
-#endif
-
-
-
-static SCM mark_root SCM_P ((SCM));
-
-static SCM
-mark_root (root)
- SCM root;
-{
- scm_root_state *s = SCM_ROOT_STATE (root);
- SCM_SETGC8MARK (root);
- scm_gc_mark (s->rootcont);
- scm_gc_mark (s->dynwinds);
- scm_gc_mark (s->continuation_stack);
- scm_gc_mark (s->continuation_stack_ptr);
- scm_gc_mark (s->progargs);
- scm_gc_mark (s->exitval);
- scm_gc_mark (s->cur_inp);
- scm_gc_mark (s->cur_outp);
- scm_gc_mark (s->cur_errp);
- scm_gc_mark (s->def_inp);
- scm_gc_mark (s->def_outp);
- scm_gc_mark (s->def_errp);
- scm_gc_mark (s->top_level_lookup_closure_var);
- scm_gc_mark (s->system_transformer);
- return SCM_ROOT_STATE (root) -> parent;
-}
-
-static scm_sizet free_root SCM_P ((SCM));
-
-static scm_sizet
-free_root (root)
- SCM root;
-{
- scm_must_free ((char *) SCM_ROOT_STATE (root));
- return sizeof (scm_root_state);
-}
-
-static int print_root SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-
-static int
-print_root (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_gen_puts (scm_regular_string, "#<root ", port);
- scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp) -> rootcont), 16, port);
- scm_gen_putc('>', port);
- return 1;
-}
-
-static scm_smobfuns root_smob =
-{
- mark_root,
- free_root,
- print_root,
- 0
-};
-
-
-
-SCM
-scm_make_root (parent)
- SCM parent;
-{
- SCM root;
- scm_root_state *root_state;
-
- root_state = (scm_root_state *) scm_must_malloc (sizeof (scm_root_state),
- "scm_make_root");
- if (SCM_NIMP (parent) && SCM_ROOTP (parent))
- {
- memcpy (root_state, SCM_ROOT_STATE (parent), sizeof (scm_root_state));
- root_state->parent = parent;
- }
- else
- {
- root_state->parent = SCM_BOOL_F;
- }
- SCM_NEWCELL (root);
- SCM_REDEFER_INTS;
- SCM_SETCAR (root, scm_tc16_root);
- SCM_SETCDR (root, root_state);
- root_state->handle = root;
- SCM_REALLOW_INTS;
- return root;
-}
-
-/* {call-with-dynamic-root}
- *
- * Suspending the current thread to evaluate a thunk on the
- * same C stack but under a new root.
- *
- * Calls to call-with-dynamic-root return exactly once (unless
- * the process is somehow exitted).
- */
-
-/* Some questions about cwdr:
-
- Couldn't the body just be a closure? Do we really need to pass
- args through to it?
-
- The semantics are a lot like catch's; in fact, we call
- scm_internal_catch to take care of that part of things. Wouldn't
- it be cleaner to say that uncaught throws just disappear into the
- ether (or print a message to stderr), and let the caller use catch
- themselves if they want to?
-
- -JimB */
-
-#if 0
-SCM scm_exitval; /* INUM with return value */
-#endif
-static int n_dynamic_roots = 0;
-
-
-/* cwdr fills out one of these structures, and then passes a pointer
- to it through scm_internal_catch to the cwdr_body and cwdr_handler
- functions, to tell them how to behave.
-
- A cwdr is a lot like a catch, except there is no tag (all
- exceptions are caught), and the body procedure takes the arguments
- passed to cwdr as A1 and ARGS. */
-
-struct cwdr_body_data {
-
- /* Arguments to pass to the cwdr body function. */
- SCM a1, args;
-
- /* Scheme procedure to use as body of cwdr. */
- SCM body_proc;
-
- /* Scheme procedure to call if a throw occurs within the cwdr. */
- SCM handler_proc;
-};
-
-
-/* Invoke the body of a cwdr, assuming that the throw handler has
- already been set up. DATA points to a struct set up by cwdr that
- says what proc to call, and what args to apply it to. */
-static SCM cwdr_body SCM_P ((void *, SCM));
-
-static SCM
-cwdr_body (void *data, SCM jmpbuf)
-{
- struct cwdr_body_data *c = (struct cwdr_body_data *) data;
-
- return scm_apply (c->body_proc, c->a1, c->args);
-}
-
-
-/* Invoke the handler of a cwdr. DATA points to a struct set up by
- cwdr that says what proc to call to handle the throw. */
-static SCM cwdr_handler SCM_P ((void *, SCM, SCM));
-
-static SCM
-cwdr_handler (void *data, SCM tag, SCM throw_args)
-{
- struct cwdr_body_data *c = (struct cwdr_body_data *) data;
-
- return scm_apply (c->handler_proc, scm_cons (tag, throw_args), SCM_EOL);
-}
-
-
-static SCM cwdr SCM_P ((SCM thunk, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start));
-
-/* This is the basic code for new root creation.
- *
- * WARNING! The order of actions in this routine is in many ways
- * critical. E. g., it is essential that an error doesn't leave Guile
- * in a messed up state. */
-
-static SCM
-cwdr (proc, a1, args, handler, stack_start)
- SCM proc;
- SCM a1;
- SCM args;
- SCM handler;
- SCM_STACKITEM *stack_start;
-{
- int old_ints_disabled = scm_ints_disabled;
- SCM old_rootcont, old_winds;
- SCM answer;
-
- /* Create a fresh root continuation.
- */
- {
- SCM new_rootcont;
- SCM_NEWCELL (new_rootcont);
- SCM_REDEFER_INTS;
- SCM_SETJMPBUF (new_rootcont,
- scm_must_malloc ((long) sizeof (scm_contregs),
- "inferior root continuation"));
- SCM_SETCAR (new_rootcont, scm_tc7_contin);
- SCM_DYNENV (new_rootcont) = SCM_EOL;
- SCM_BASE (new_rootcont) = stack_start;
- SCM_SEQ (new_rootcont) = ++n_dynamic_roots;
-#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (new_rootcont) = 0;
-#endif
- old_rootcont = scm_rootcont;
- scm_rootcont = new_rootcont;
- SCM_REALLOW_INTS;
- }
-
- /* Exit caller's dynamic state.
- */
- old_winds = scm_dynwinds;
- scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
-#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (old_rootcont) = scm_last_debug_frame;
- scm_last_debug_frame = 0;
-#endif
-
- /* Catch all errors. */
- {
- struct cwdr_body_data c;
-
- c.a1 = a1;
- c.args = args;
- c.body_proc = proc;
- c.handler_proc = handler;
-
- answer = scm_internal_catch (SCM_BOOL_T, cwdr_body, cwdr_handler, &c);
- }
-
- scm_dowinds (old_winds, - scm_ilength (old_winds));
- SCM_REDEFER_INTS;
-#ifdef DEBUG_EXTENSIONS
- scm_last_debug_frame = SCM_DFRAME (old_rootcont);
-#endif
- scm_rootcont = old_rootcont;
- SCM_REALLOW_INTS;
- scm_ints_disabled = old_ints_disabled;
- return answer;
-}
-
-
-SCM_PROC(s_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root);
-SCM
-scm_call_with_dynamic_root (thunk, handler)
- SCM thunk;
- SCM handler;
-{
- SCM_STACKITEM stack_place;
-
- return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
-}
-
-SCM_PROC(s_dynamic_root, "dynamic-root", 0, 0, 0, scm_dynamic_root);
-SCM
-scm_dynamic_root ()
-{
- return scm_ulong2num (SCM_SEQ (scm_root->rootcont));
-}
-
-SCM
-scm_apply_with_dynamic_root (proc, a1, args, handler)
- SCM proc;
- SCM a1;
- SCM args;
- SCM handler;
-{
- SCM_STACKITEM stack_place;
- return cwdr (proc, a1, args, handler, &stack_place);
-}
-
-
-
-/* Call thunk(closure) underneath a top-level error handler.
- * If an error occurs, pass the exitval through err_filter and return it.
- * If no error occurs, return the value of thunk.
- */
-
-
-#ifdef _UNICOS
-typedef int setjmp_type;
-#else
-typedef long setjmp_type;
-#endif
-
-
-
-SCM
-scm_call_catching_errors (thunk, err_filter, closure)
- SCM (*thunk)();
- SCM (*err_filter)();
- void *closure;
-{
- SCM answer;
- setjmp_type i;
-#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (scm_rootcont) = scm_last_debug_frame;
-#endif
- i = setjmp (SCM_JMPBUF (scm_rootcont));
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
- if (!i)
- {
- scm_gc_heap_lock = 0;
- answer = thunk (closure);
- }
- else
- {
- scm_gc_heap_lock = 1;
- answer = err_filter (scm_exitval, closure);
- }
- return answer;
-}
-
-void
-scm_init_root ()
-{
- scm_tc16_root = scm_newsmob (&root_smob);
-#include "root.x"
-}
diff --git a/libguile/root.h b/libguile/root.h
deleted file mode 100644
index 37857d47d..000000000
--- a/libguile/root.h
+++ /dev/null
@@ -1,157 +0,0 @@
-/* classes: h_files */
-
-#ifndef ROOTH
-#define ROOTH
-
-/* Copyright (C) 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-
-
-#include "libguile/__scm.h"
-#include "libguile/debug.h"
-
-
-
-#define scm_flo0 scm_sys_protects[0]
-#define scm_listofnull scm_sys_protects[1]
-#define scm_undefineds scm_sys_protects[2]
-#define scm_nullvect scm_sys_protects[3]
-#define scm_nullstr scm_sys_protects[4]
-#define scm_symhash scm_sys_protects[5]
-#define scm_weak_symhash scm_sys_protects[6]
-#define scm_symhash_vars scm_sys_protects[7]
-#define scm_kw_obarray scm_sys_protects[8]
-#define scm_type_obj_list scm_sys_protects[9]
-#define scm_first_type scm_sys_protects[10]
-#define scm_stand_in_procs scm_sys_protects[11]
-#define scm_object_whash scm_sys_protects[12]
-#define scm_permobjs scm_sys_protects[13]
-#define scm_asyncs scm_sys_protects[14]
-#ifdef DEBUG_EXTENSIONS
-#define scm_source_whash scm_sys_protects[15]
-#define SCM_NUM_PROTECTS 16
-#else
-#define SCM_NUM_PROTECTS 15
-#endif
-
-extern SCM scm_sys_protects[];
-
-
-
-extern long scm_tc16_root;
-
-#define SCM_ROOTP(obj) (scm_tc16_root == SCM_TYP16 (obj))
-#define SCM_ROOT_STATE(root) ((scm_root_state *) SCM_CDR (root))
-
-typedef struct scm_root_state
-{
- SCM_STACKITEM * stack_base;
- jmp_buf save_regs_gc_mark;
- int errjmp_bad;
-
- SCM rootcont;
- SCM dynwinds;
- SCM continuation_stack;
- SCM continuation_stack_ptr;
-#ifdef DEBUG_EXTENSIONS
- /* It is very inefficient to have this variable in the root state. */
- scm_debug_frame *last_debug_frame;
-#endif
-
- SCM progargs; /* vestigial */
- SCM exitval; /* vestigial */
-
- SCM cur_inp;
- SCM cur_outp;
- SCM cur_errp;
- SCM def_inp;
- SCM def_outp;
- SCM def_errp;
-
- SCM system_transformer;
- SCM top_level_lookup_closure_var;
-
- SCM handle; /* The root object for this root state */
- SCM parent; /* The parent root object */
-} scm_root_state;
-
-#define scm_stack_base (scm_root->stack_base)
-#define scm_save_regs_gc_mark (scm_root->save_regs_gc_mark)
-#define scm_errjmp_bad (scm_root->errjmp_bad)
-
-#define scm_rootcont (scm_root->rootcont)
-#define scm_dynwinds (scm_root->dynwinds)
-#define scm_continuation_stack (scm_root->continuation_stack)
-#define scm_continuation_stack_ptr (scm_root->continuation_stack_ptr)
-#define scm_progargs (scm_root->progargs)
-#ifdef USE_THREADS
-#define scm_last_debug_frame (scm_root->last_debug_frame)
-#endif
-#define scm_exitval (scm_root->exitval)
-#define scm_cur_inp (scm_root->cur_inp)
-#define scm_cur_outp (scm_root->cur_outp)
-#define scm_cur_errp (scm_root->cur_errp)
-#define scm_def_inp (scm_root->def_inp)
-#define scm_def_outp (scm_root->def_outp)
-#define scm_def_errp (scm_root->def_errp)
-#define scm_top_level_lookup_closure_var \
- (scm_root->top_level_lookup_closure_var)
-#define scm_system_transformer (scm_root->system_transformer)
-
-#ifdef USE_THREADS
-#define scm_root ((scm_root_state *) SCM_THREAD_LOCAL_DATA)
-#define scm_set_root(new_root) SCM_SET_THREAD_LOCAL_DATA (new_root)
-#else /* USE_THREADS */
-extern struct scm_root_state *scm_root;
-#define scm_set_root(new_root) (scm_root = (new_root))
-#endif /* USE_THREADS */
-
-
-
-extern SCM scm_make_root SCM_P ((SCM parent));
-extern SCM scm_call_with_dynamic_root SCM_P ((SCM thunk, SCM handler));
-extern SCM scm_apply_with_dynamic_root SCM_P ((SCM proc, SCM a1, SCM args, SCM handler));
-extern SCM scm_call_catching_errors SCM_P ((SCM (*thunk)(), SCM (*err_filter)(), void * closure));
-extern void scm_init_root SCM_P ((void));
-
-#endif /* ROOTH */
diff --git a/libguile/scmconfig.h.in b/libguile/scmconfig.h.in
deleted file mode 100644
index 4578d3ace..000000000
--- a/libguile/scmconfig.h.in
+++ /dev/null
@@ -1,287 +0,0 @@
-/* scmconfig.h.in. Generated automatically from configure.in by autoheader. */
-
-/* Define if on AIX 3.
- System headers sometimes define this.
- We just want to avoid a redefinition error message. */
-#ifndef _ALL_SOURCE
-#undef _ALL_SOURCE
-#endif
-
-/* Define to empty if the keyword does not work. */
-#undef const
-
-/* Define to the type of elements in the array set by `getgroups'.
- Usually this is either `int' or `gid_t'. */
-#undef GETGROUPS_T
-
-/* Define to `int' if <sys/types.h> doesn't define. */
-#undef gid_t
-
-/* Define if your struct stat has st_blksize. */
-#undef HAVE_ST_BLKSIZE
-
-/* Define if your struct stat has st_blocks. */
-#undef HAVE_ST_BLOCKS
-
-/* Define if your struct stat has st_rdev. */
-#undef HAVE_ST_RDEV
-
-/* Define if you have <sys/wait.h> that is POSIX.1 compatible. */
-#undef HAVE_SYS_WAIT_H
-
-/* Define if on MINIX. */
-#undef _MINIX
-
-/* Define to `int' if <sys/types.h> doesn't define. */
-#undef mode_t
-
-/* Define if the system does not provide POSIX.1 features except
- with this defined. */
-#undef _POSIX_1_SOURCE
-
-/* Define if you need to in order for stat and other things to work. */
-#undef _POSIX_SOURCE
-
-/* Define as the return type of signal handlers (int or void). */
-#undef RETSIGTYPE
-
-/* Define if you have the ANSI C header files. */
-#undef STDC_HEADERS
-
-/* Define if you can safely include both <sys/time.h> and <time.h>. */
-#undef TIME_WITH_SYS_TIME
-
-/* Define to `int' if <sys/types.h> doesn't define. */
-#undef uid_t
-
-/* Define these two if you want support for debugging of Scheme
- programs. */
-#undef DEBUG_EXTENSIONS
-#undef READER_EXTENSIONS
-
-/* Define this if your system has a way to set a stdio stream's file
- descriptor. You should also copy fd.h.in to fd.h, and give the
- macro SET_FILE_FD_FIELD an appropriate definition. See
- configure.in for more details. */
-#undef HAVE_FD_SETTER
-
-/* Define this if your system has a way to set a stdio stream's file
- descriptor. You should also copy fd.h.in to fd.h, and give the
- macro SET_FILE_FD_FIELD an appropriate definition. See
- configure.in for more details. */
-#undef HAVE_FD_SETTER
-
-/* Set this to the name of a field in FILE which contains the number
- of buffered characters waiting to be read. */
-#undef FILE_CNT_FIELD
-
-/* Define this if your stdio has _gptr and _egptr fields which can
- be compared to give the number of buffered characters waiting to
- be read. */
-#undef FILE_CNT_GPTR
-
-/* Define this if your stdio has _IO_read_ptr and _IO_read_end fields
- which can be compared to give the number of buffered characters
- waiting to be read. */
-#undef FILE_CNT_READPTR
-
-/* Define this if your system defines struct linger, for use with the
- getsockopt and setsockopt system calls. */
-#undef HAVE_STRUCT_LINGER
-
-/* Define this if floats are the same size as longs. */
-#undef SCM_SINGLES
-
-/* Define this if a callee's stack frame has a higher address than the
- caller's stack frame. On most machines, this is not the case. */
-#undef SCM_STACK_GROWS_UP
-
-/* Define this if <utime.h> doesn't define struct utimbuf unless
- _POSIX_SOURCE is #defined. See GUILE_STRUCT_UTIMBUF in aclocal.m4. */
-#undef UTIMBUF_NEEDS_POSIX
-
-/* Define this if we should #include <libc.h> when we've already
- #included <unistd.h>. On some systems, they conflict, and libc.h
- should be omitted. See GUILE_HEADER_LIBC_WITH_UNISTD in
- aclocal.m4. */
-#undef LIBC_H_WITH_UNISTD_H
-
-/* Define these to indicate the current version of Guile. These
- values are supposed to be supplied by the configuration system. */
-#undef GUILE_MAJOR_VERSION
-#undef GUILE_MINOR_VERSION
-#undef GUILE_VERSION
-
-/* Define if using cooperative multithreading. */
-#undef USE_COOP_THREADS
-
-/* Define if using "FSU" pthreads. */
-#undef USE_FSU_PTHREADS
-
-/* Define if using MIT pthreads. */
-#undef USE_MIT_PTHREADS
-
-/* Define if using PCthreads pthreads. */
-#undef USE_PCTHREADS_PTHREADS
-
-/* Define if using any sort of threads. */
-#undef USE_THREADS
-
-/* Name of this package. */
-#undef PACKAGE
-
-/* Define if you want support for dynamic linking. */
-#undef DYNAMIC_LINKING
-
-/* Define if you have the ctermid function. */
-#undef HAVE_CTERMID
-
-/* Define if you have the ftime function. */
-#undef HAVE_FTIME
-
-/* Define if you have the getcwd function. */
-#undef HAVE_GETCWD
-
-/* Define if you have the geteuid function. */
-#undef HAVE_GETEUID
-
-/* Define if you have the inet_aton function. */
-#undef HAVE_INET_ATON
-
-/* Define if you have the lstat function. */
-#undef HAVE_LSTAT
-
-/* Define if you have the mkdir function. */
-#undef HAVE_MKDIR
-
-/* Define if you have the mknod function. */
-#undef HAVE_MKNOD
-
-/* Define if you have the nice function. */
-#undef HAVE_NICE
-
-/* Define if you have the putenv function. */
-#undef HAVE_PUTENV
-
-/* Define if you have the readlink function. */
-#undef HAVE_READLINK
-
-/* Define if you have the rename function. */
-#undef HAVE_RENAME
-
-/* Define if you have the rmdir function. */
-#undef HAVE_RMDIR
-
-/* Define if you have the select function. */
-#undef HAVE_SELECT
-
-/* Define if you have the setegid function. */
-#undef HAVE_SETEGID
-
-/* Define if you have the seteuid function. */
-#undef HAVE_SETEUID
-
-/* Define if you have the setlocale function. */
-#undef HAVE_SETLOCALE
-
-/* Define if you have the setpgid function. */
-#undef HAVE_SETPGID
-
-/* Define if you have the setsid function. */
-#undef HAVE_SETSID
-
-/* Define if you have the shl_load function. */
-#undef HAVE_SHL_LOAD
-
-/* Define if you have the strerror function. */
-#undef HAVE_STRERROR
-
-/* Define if you have the strftime function. */
-#undef HAVE_STRFTIME
-
-/* Define if you have the strptime function. */
-#undef HAVE_STRPTIME
-
-/* Define if you have the symlink function. */
-#undef HAVE_SYMLINK
-
-/* Define if you have the sync function. */
-#undef HAVE_SYNC
-
-/* Define if you have the tcgetpgrp function. */
-#undef HAVE_TCGETPGRP
-
-/* Define if you have the tcsetpgrp function. */
-#undef HAVE_TCSETPGRP
-
-/* Define if you have the times function. */
-#undef HAVE_TIMES
-
-/* Define if you have the uname function. */
-#undef HAVE_UNAME
-
-/* Define if you have the waitpid function. */
-#undef HAVE_WAITPID
-
-/* Define if you have the <dirent.h> header file. */
-#undef HAVE_DIRENT_H
-
-/* Define if you have the <libc.h> header file. */
-#undef HAVE_LIBC_H
-
-/* Define if you have the <limits.h> header file. */
-#undef HAVE_LIMITS_H
-
-/* Define if you have the <malloc.h> header file. */
-#undef HAVE_MALLOC_H
-
-/* Define if you have the <memory.h> header file. */
-#undef HAVE_MEMORY_H
-
-/* Define if you have the <ndir.h> header file. */
-#undef HAVE_NDIR_H
-
-/* Define if you have the <string.h> header file. */
-#undef HAVE_STRING_H
-
-/* Define if you have the <sys/dir.h> header file. */
-#undef HAVE_SYS_DIR_H
-
-/* Define if you have the <sys/ioctl.h> header file. */
-#undef HAVE_SYS_IOCTL_H
-
-/* Define if you have the <sys/ndir.h> header file. */
-#undef HAVE_SYS_NDIR_H
-
-/* Define if you have the <sys/select.h> header file. */
-#undef HAVE_SYS_SELECT_H
-
-/* Define if you have the <sys/time.h> header file. */
-#undef HAVE_SYS_TIME_H
-
-/* Define if you have the <sys/timeb.h> header file. */
-#undef HAVE_SYS_TIMEB_H
-
-/* Define if you have the <sys/times.h> header file. */
-#undef HAVE_SYS_TIMES_H
-
-/* Define if you have the <sys/types.h> header file. */
-#undef HAVE_SYS_TYPES_H
-
-/* Define if you have the <sys/utime.h> header file. */
-#undef HAVE_SYS_UTIME_H
-
-/* Define if you have the <time.h> header file. */
-#undef HAVE_TIME_H
-
-/* Define if you have the <unistd.h> header file. */
-#undef HAVE_UNISTD_H
-
-/* Define if you have the <utime.h> header file. */
-#undef HAVE_UTIME_H
-
-/* Define if you have the dl library (-ldl). */
-#undef HAVE_LIBDL
-
-/* Define if you have the dld library (-ldld). */
-#undef HAVE_LIBDLD
diff --git a/libguile/scmhob.h b/libguile/scmhob.h
deleted file mode 100644
index 6bd61489a..000000000
--- a/libguile/scmhob.h
+++ /dev/null
@@ -1,205 +0,0 @@
-/* This was modified to try out compiling with Guile. */
-
-
-/* scmhob.h is a header file for scheme source compiled with hobbit4d
- Copyright (C) 1992, 1993, 1994, 1995 Tanel Tammet
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 1, or (at your option)
-any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-*/
-
-
-#include <stdio.h>
-#include <ctype.h>
-#include "libguile/_scm.h"
-
-
-
-#define abrt scm_abort
-#define absval scm_abs
-#define angle scm_angle
-#define append scm_append
-#define assoc scm_assoc
-#define assq scm_assq
-#define assv scm_assv
-#define big2dbl scm_big2dbl
-#define close_port scm_close_port
-#define cons scm_cons
-#define cur_input_port scm_current_input_port
-#define cur_output_port scm_current_output_port
-#define difference scm_difference
-#define display scm_display
-#define divide scm_divide
-#define eof_objectp scm_eof_object_p
-#define eqp scm_eq_p
-#define equal scm_equal_p
-#define eqv scm_eqv_p
-#define evenp scm_even_p
-#define exactp scm_exact_p
-#define greaterp scm_gr_p
-#define greqp scm_geq_p
-#define imag_part scm_imag_part
-#define in2ex scm_inexact_to_exact
-#define inexactp scm_inexact_p
-#define input_portp scm_input_port_p
-#define intp scm_integer_p
-#define length scm_length
-#define leqp scm_leq_p
-#define lessp scm_less_p
-#define lgcd scm_gcd
-#define list_ref scm_list_ref
-#define list_tail scm_list_tail
-#define listp scm_list_p
-#define llcm scm_lcm
-#define lmax scm_max
-#define lmin scm_min
-#define lquotient scm_quotient
-#define lread(X) scm_read((X), SCM_UNDEFINED)
-#define lremainder scm_remainder
-#define lwrite scm_write
-#define magnitude scm_magnitude
-#define makcclo scm_makcclo
-#define makdbl scm_makdbl
-#define make_string scm_make_string
-#define make_vector scm_make_vector
-#define makpolar scm_make_polar
-#define makrect scm_make_rectangular
-#define member scm_member
-#define memq scm_memq
-#define memv scm_memv
-#define modulo scm_modulo
-#define my_time scm_get_internal_run_time
-#define negativep scm_negative_p
-#define newline scm_newline
-#define number2string scm_number_to_string
-#define oddp scm_odd_p
-#define open_file scm_open_file
-#define output_portp scm_output_port_p
-#define peek_char scm_peek_char
-#define positivep scm_positive_p
-#define procedurep scm_procedure_p
-#define product scm_product
-#define quit scm_quit
-#define read_char scm_read_char
-#define real_part scm_real_part
-#define realp scm_real_p
-#define reverse scm_reverse
-#define set_inp scm_set_current_input_port
-#define set_outp scm_set_current_output_port
-#define st_append scm_string_append
-#define st_equal scm_string_equal_p
-#define st_leqp scm_string_leq_p
-#define st_lessp scm_string_less_p
-#define st_set scm_string_set_x
-#define stci_equal scm_string_ci_equal_p
-#define stci_leqp scm_string_ci_leq_p
-#define stci_lessp scm_string_ci_less_p
-#define string scm_string
-#define string2list scm_string_to_list
-#define string2number scm_string_to_number
-#define string2symbol scm_string_to_symbol
-#define string_copy scm_string_copy
-#define string_fill scm_string_fill_x
-#define substring scm_substring
-#define sum scm_sum
-#define symbol2string scm_symbol_to_string
-#define vector scm_vector
-#define vector2list scm_vector_to_list
-#define vector_ref scm_vector_ref
-#define vector_set scm_vector_set_x
-#define write_char scm_write_char
-#define zerop scm_zero_p
-
-
-
-#define STBL_VECTOR_SET(v,k,o) (v[((long)SCM_INUM(k))] = o)
-#define STBL_VECTOR_REF(v,k) (v[((long)SCM_INUM(k))])
-#define CHAR_LESSP(x,y) ((SCM_ICHR(x) < SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F)
-#define CHAR_LEQP(x,y) ((SCM_ICHR(x) <= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F)
-#define CHCI_EQ(x,y) ((upcase[SCM_ICHR(x)]==upcase[SCM_ICHR(y)]) ? SCM_BOOL_T : SCM_BOOL_F)
-#define CHCI_LESSP(x,y) ((upcase[SCM_ICHR(x)] < upcase[SCM_ICHR(y)]) ? SCM_BOOL_T : SCM_BOOL_F)
-#define CHCI_LEQP(x,y) ((upcase[SCM_ICHR(x)] <= upcase[SCM_ICHR(y)]) ? SCM_BOOL_T : SCM_BOOL_F)
-#define CHAR_ALPHAP(chr) ((isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
-#define SCM_CHAR_NUMP(chr) ((isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
-#define CHAR_WHITEP(chr) ((isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
-#define CHAR_UPPERP(chr) ((isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
-#define CHAR_LOWERP(chr) ((isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F)
-#define CHAR2INT(chr) SCM_MAKINUM(SCM_ICHR(chr))
-#define INT2CHAR(n) SCM_MAKICHR(SCM_INUM(n))
-#define CHAR_UPCASE(chr) SCM_MAKICHR(upcase[SCM_ICHR(chr)])
-#define CHAR_DOWNCASE(chr) SCM_MAKICHR(downcase[SCM_ICHR(chr)])
-#define ST_LENGTH(str) SCM_MAKINUM(SCM_LENGTH(str))
-#define ST_REF(str,k) SCM_MAKICHR(SCM_CHARS(str)[SCM_INUM(k)])
-#define VECTOR_LENGTH(v) SCM_MAKINUM(SCM_LENGTH(v))
-
-#ifdef SCM_FLOATS
-#include <math.h>
-#endif
-#ifdef SCM_BIGDIG
-#define PRE_TRANSC_FUN(x) (SCM_INUMP(x) ? (double) SCM_INUM(x) : (SCM_REALP(x) ? (double) SCM_REALPART(x) : (double) big2dbl(x)))
-#else
-#define PRE_TRANSC_FUN(x) (SCM_INUMP(x) ? (double) SCM_INUM(x) : (double) SCM_REALPART(x))
-#endif
-
-#define SIN_FUN(x) (makdbl( sin( PRE_TRANSC_FUN(x)), 0.0))
-#define COS_FUN(x) (makdbl( cos( PRE_TRANSC_FUN(x)), 0.0))
-#define TAN_FUN(x) (makdbl( tan( PRE_TRANSC_FUN(x)), 0.0))
-#define ASIN_FUN(x) (makdbl( asin( PRE_TRANSC_FUN(x)), 0.0))
-#define ACOS_FUN(x) (makdbl( acos( PRE_TRANSC_FUN(x)), 0.0))
-#define ATAN_FUN(x) (makdbl( atan( PRE_TRANSC_FUN(x)), 0.0))
-#define SINH_FUN(x) (makdbl( sinh( PRE_TRANSC_FUN(x)), 0.0))
-#define COSH_FUN(x) (makdbl( cosh( PRE_TRANSC_FUN(x)), 0.0))
-#define TANH_FUN(x) (makdbl( tanh( PRE_TRANSC_FUN(x)), 0.0))
-#define ASINH_FUN(x) (makdbl( asinh( PRE_TRANSC_FUN(x)), 0.0))
-#define ACOSH_FUN(x) (makdbl( acosh( PRE_TRANSC_FUN(x)), 0.0))
-#define ATANH_FUN(x) (makdbl( atanh( PRE_TRANSC_FUN(x)), 0.0))
-#define SQRT_FUN(x) (makdbl( sqrt( PRE_TRANSC_FUN(x)), 0.0))
-#define EXPT_FUN(x,y) (makdbl( pow(( PRE_TRANSC_FUN(x)), ( PRE_TRANSC_FUN(y))), 0.0))
-#define EXP_FUN(x) (makdbl( exp( PRE_TRANSC_FUN(x)), 0.0))
-#define LOG_FUN(x) (makdbl( log( PRE_TRANSC_FUN(x)), 0.0))
-#define ABS_FUN(x) (makdbl( fabs( PRE_TRANSC_FUN(x)), 0.0))
-#define EX2IN_FUN(x) (makdbl( PRE_TRANSC_FUN(x), 0.0))
-#define SCM_FLOOR_FUN(x) (makdbl( floor( PRE_TRANSC_FUN(x)), 0.0))
-#define CEILING_FUN(x) (makdbl( ceil( PRE_TRANSC_FUN(x)), 0.0))
-#define TRUNCATE_FUN(x) (makdbl( ltrunc( PRE_TRANSC_FUN(x)), 0.0))
-#define ROUND_FUN(x) (makdbl(round( PRE_TRANSC_FUN(x)), 0.0))
-
-/* the following defs come from the #ifdef HOBBIT part of scm.h */
-
-#define SBOOL(x) ((x) ? SCM_BOOL_T : SCM_BOOL_F)
-
-#define BOOLEAN_P(x) ((x)==SCM_BOOL_T || (x)==SCM_BOOL_F)
-#define CHAR_P SCM_ICHRP
-#define SYMBOL_P(x) (SCM_ISYMP(x) || (!(SCM_IMP(x)) && SCM_SYMBOLP(x)))
-#define VECTOR_P(x) (!(SCM_IMP(x)) && SCM_VECTORP(x))
-#define PAIR_P(x) (!(SCM_IMP(x)) && SCM_CONSP(x))
-#define NUMBER_P SCM_INUMP
-#define INTEGER_P SCM_INUMP
-#define STRING_P(x) (!(SCM_IMP(x)) && SCM_STRINGP(x))
-#define NULL_P SCM_NULLP
-#define ZERO_P(x) ((x)==SCM_INUM0)
-#define POSITIVE_P(x) ((x) > SCM_INUM0)
-#define NEGATIVE_P(x) ((x) < SCM_INUM0)
-
-#define NOT(x) ((x)==SCM_BOOL_F ? SCM_BOOL_T : SCM_BOOL_F)
-#define SET_CAR(x,y) (CAR(x) = (SCM)(y))
-#define SET_CDR(x,y) (CDR(x) = (SCM)(y))
-#define VECTOR_SET(v,k,o) (SCM_VELTS(v)[((long)SCM_INUM(k))] = o)
-#define VECTOR_REF(v,k) (SCM_VELTS(v)[((long)SCM_INUM(k))])
-#define CL_VECTOR_SET(v,k,o) (SCM_VELTS(v)[k] = o)
-#define CL_VECTOR_REF(v,k) (SCM_VELTS(v)[k])
-#define GLOBAL(x) (*(x))
-
-#define append2(lst1,lst2) (append(scm_cons2(lst1,lst2,SCM_EOL)))
-#define procedure_pred_(x) (SCM_BOOL_T==procedurep(x))
diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c
deleted file mode 100644
index 7429a1598..000000000
--- a/libguile/scmsigs.c
+++ /dev/null
@@ -1,368 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include <signal.h>
-#include "_scm.h"
-
-#include "scmsigs.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-
-
-
-#if (__TURBOC__==1)
-#define signal ssignal /* Needed for TURBOC V1.0 */
-#endif
-
-#ifdef USE_MIT_PTHREADS
-#undef signal
-#define signal pthread_signal
-#endif
-
-
-
-/* SIGRETTYPE is the type that signal handlers return. See <signal.h>*/
-
-#ifdef RETSIGTYPE
-#define SIGRETTYPE RETSIGTYPE
-#else
-#ifdef STDC_HEADERS
-#if (__TURBOC__==1)
-#define SIGRETTYPE int
-#else
-#define SIGRETTYPE void
-#endif
-#else
-#ifdef linux
-#define SIGRETTYPE void
-#else
-#define SIGRETTYPE int
-#endif
-#endif
-#endif
-
-#ifdef vms
-#ifdef __GNUC__
-#define SIGRETTYPE int
-#endif
-#endif
-
-
-
-#define SIGFN(NAME, SCM_NAME, SIGNAL) \
-static SIGRETTYPE \
-NAME (sig) \
- int sig; \
-{ \
- signal (SIGNAL, NAME); \
- scm_take_signal (SCM_NAME); \
-}
-
-#ifdef SIGHUP
-SIGFN(scm_hup_signal, SCM_HUP_SIGNAL, SIGHUP)
-#endif
-
-#ifdef SIGINT
-SIGFN(scm_int_signal, SCM_INT_SIGNAL, SIGINT)
-#endif
-
-#ifdef SIGFPE
-SIGFN(scm_fpe_signal, SCM_FPE_SIGNAL, SIGFPE)
-#endif
-
-#ifdef SIGBUS
-SIGFN(scm_bus_signal, SCM_BUS_SIGNAL, SIGBUS)
-#endif
-
-#ifdef SIGSEGV
-SIGFN(scm_segv_signal, SCM_SEGV_SIGNAL, SIGSEGV)
-#endif
-
-#ifdef SIGALRM
-SIGFN(scm_alrm_signal, SCM_ALRM_SIGNAL, SIGALRM)
-#endif
-
-#define FAKESIGFN(NAME, SCM_NAME) \
-static SIGRETTYPE \
-NAME (sig) \
- int sig; \
-{ \
- scm_take_signal (SCM_NAME); \
-}
-
-#if 0
-/* !!! */
-FAKESIGFN(scm_gc_signal, SCM_GC_SIGNAL)
-FAKESIGFN(scm_tick_signal, SCM_TICK_SIGNAL)
-#endif
-
-
-SCM_PROC(s_alarm, "alarm", 1, 0, 0, scm_alarm);
-
-SCM
-scm_alarm (i)
- SCM i;
-{
- unsigned int j;
- SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_alarm);
- SCM_SYSCALL (j = alarm (SCM_INUM (i)));
- return SCM_MAKINUM (j);
-}
-
-
-SCM_PROC(s_pause, "pause", 0, 0, 0, scm_pause);
-
-SCM
-scm_pause ()
-{
- pause ();
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC(s_sleep, "sleep", 1, 0, 0, scm_sleep);
-
-SCM
-scm_sleep (i)
- SCM i;
-{
- unsigned int j;
- SCM_ASSERT (SCM_INUMP (i) && (SCM_INUM (i) >= 0), i, SCM_ARG1, s_sleep);
-#ifdef __HIGHC__
- SCM_SYSCALL(j = 0; sleep(SCM_INUM(i)););
-#else
- SCM_SYSCALL(j = sleep(SCM_INUM(i)););
-#endif
- return SCM_MAKINUM (j);
-}
-
-SCM_PROC(s_raise, "raise", 1, 0, 0, scm_raise);
-
-SCM
-scm_raise(sig)
- SCM sig;
-{
- SCM_ASSERT(SCM_INUMP(sig), sig, SCM_ARG1, s_raise);
-# ifdef vms
- return SCM_MAKINUM(gsignal((int)SCM_INUM(sig)));
-# else
- return kill (getpid(), (int)SCM_INUM(sig)) ? SCM_BOOL_F : SCM_BOOL_T;
-# endif
-}
-
-
-#ifdef SIGHUP
-static SIGRETTYPE (*oldhup) ();
-#endif
-
-#ifdef SIGINT
-static SIGRETTYPE (*oldint) ();
-#endif
-
-#ifdef SIGFPE
-static SIGRETTYPE (*oldfpe) ();
-#endif
-
-#ifdef SIGBUS
-static SIGRETTYPE (*oldbus) ();
-#endif
-
-#ifdef SIGSEGV /* AMIGA lacks! */
-static SIGRETTYPE (*oldsegv) ();
-#endif
-
-#ifdef SIGALRM
-static SIGRETTYPE (*oldalrm) ();
-#endif
-
-#ifdef SIGPIPE
-static SIGRETTYPE (*oldpipe) ();
-#endif
-
-
-
-void
-scm_init_signals ()
-{
-#ifdef SIGINT
- oldint = signal (SIGINT, scm_int_signal);
-#endif
-#ifdef SIGHUP
- oldhup = signal (SIGHUP, scm_hup_signal);
-#endif
-#ifdef SIGFPE
- oldfpe = signal (SIGFPE, scm_fpe_signal);
-#endif
-#ifdef SIGBUS
- oldbus = signal (SIGBUS, scm_bus_signal);
-#endif
-#ifdef SIGSEGV /* AMIGA lacks! */
- oldsegv = signal (SIGSEGV, scm_segv_signal);
-#endif
-#ifdef SIGALRM
- alarm (0); /* kill any pending ALRM interrupts */
- oldalrm = signal (SIGALRM, scm_alrm_signal);
-#endif
-#ifdef SIGPIPE
- oldpipe = signal (SIGPIPE, SIG_IGN);
-#endif
-#ifdef ultrix
- siginterrupt (SIGINT, 1);
- siginterrupt (SIGALRM, 1);
- siginterrupt (SIGHUP, 1);
- siginterrupt (SIGPIPE, 1);
-#endif /* ultrix */
-}
-
-/* This is used in preparation for a possible fork(). Ignore all
- signals before the fork so that child will catch only if it
- establishes a handler */
-
-void
-scm_ignore_signals ()
-{
-#ifdef ultrix
- siginterrupt (SIGINT, 0);
- siginterrupt (SIGALRM, 0);
- siginterrupt (SIGHUP, 0);
- siginterrupt (SIGPIPE, 0);
-#endif /* ultrix */
- signal (SIGINT, SIG_IGN);
-#ifdef SIGHUP
- signal (SIGHUP, SIG_DFL);
-#endif
-#ifdef SCM_FLOATS
- signal (SIGFPE, SIG_DFL);
-#endif
-#ifdef SIGBUS
- signal (SIGBUS, SIG_DFL);
-#endif
-#ifdef SIGSEGV /* AMIGA lacks! */
- signal (SIGSEGV, SIG_DFL);
-#endif
- /* Some documentation claims that ALRMs are cleared accross forks.
- If this is not always true then the value returned by alarm(0)
- will have to be saved and scm_unignore_signals() will have to
- reinstate it. */
- /* This code should be neccessary only if the forked process calls
- alarm() without establishing a handler:
- #ifdef SIGALRM
- oldalrm = signal(SIGALRM, SIG_DFL);
- #endif */
- /* These flushes are per warning in man page on fork(). */
- fflush (stdout);
- fflush (stderr);
-}
-
-
-void
-scm_unignore_signals ()
-{
- signal (SIGINT, scm_int_signal);
-#ifdef SIGHUP
- signal (SIGHUP, scm_hup_signal);
-#endif
-#ifdef SCM_FLOATS
- signal (SIGFPE, scm_fpe_signal);
-#endif
-#ifdef SIGBUS
- signal (SIGBUS, scm_bus_signal);
-#endif
-#ifdef SIGSEGV /* AMIGA lacks! */
- signal (SIGSEGV, scm_segv_signal);
-#endif
-#ifdef SIGALRM
- signal (SIGALRM, scm_alrm_signal);
-#endif
-#ifdef ultrix
- siginterrupt (SIGINT, 1);
- siginterrupt (SIGALRM, 1);
- siginterrupt (SIGHUP, 1);
- siginterrupt (SIGPIPE, 1);
-#endif /* ultrix */
-}
-
-SCM_PROC (s_restore_signals, "restore-signals", 0, 0, 0, scm_restore_signals);
-
-SCM
-scm_restore_signals ()
-{
-#ifdef ultrix
- siginterrupt (SIGINT, 0);
- siginterrupt (SIGALRM, 0);
- siginterrupt (SIGHUP, 0);
- siginterrupt (SIGPIPE, 0);
-#endif /* ultrix */
- signal (SIGINT, oldint);
-#ifdef SIGHUP
- signal (SIGHUP, oldhup);
-#endif
-#ifdef SCM_FLOATS
- signal (SIGFPE, oldfpe);
-#endif
-#ifdef SIGBUS
- signal (SIGBUS, oldbus);
-#endif
-#ifdef SIGSEGV /* AMIGA lacks! */
- signal (SIGSEGV, oldsegv);
-#endif
-#ifdef SIGPIPE
- signal (SIGPIPE, oldpipe);
-#endif
-#ifdef SIGALRM
- alarm (0); /* kill any pending ALRM interrupts */
- signal (SIGALRM, oldalrm);
-#endif
- return SCM_UNSPECIFIED;
-}
-
-
-
-void
-scm_init_scmsigs ()
-{
-#include "scmsigs.x"
-}
-
diff --git a/libguile/scmsigs.h b/libguile/scmsigs.h
deleted file mode 100644
index 3b8bdc48c..000000000
--- a/libguile/scmsigs.h
+++ /dev/null
@@ -1,60 +0,0 @@
-/* classes: h_files */
-
-#ifndef SCMSIGSH
-#define SCMSIGSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-
-extern SCM scm_alarm SCM_P ((SCM i));
-extern SCM scm_pause SCM_P ((void));
-extern SCM scm_sleep SCM_P ((SCM i));
-extern SCM scm_raise SCM_P ((SCM sig));
-extern void scm_init_signals SCM_P ((void));
-extern void scm_ignore_signals SCM_P ((void));
-extern void scm_unignore_signals SCM_P ((void));
-extern SCM scm_restore_signals SCM_P ((void));
-extern void scm_init_scmsigs SCM_P ((void));
-
-#endif /* SCMSIGSH */
diff --git a/libguile/sequences.c b/libguile/sequences.c
deleted file mode 100644
index 38c59e082..000000000
--- a/libguile/sequences.c
+++ /dev/null
@@ -1,113 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-
-#include "sequences.h"
-
-
-
-
-
-int
-scm_obj_length (obj)
- SCM obj;
-{
- int i;
- i = scm_ilength(obj);
- if (i >= 0)
- return i;
- else if (SCM_NIMP (obj))
- {
- if (SCM_ROSTRINGP (obj))
- return SCM_ROLENGTH (obj);
- else if (SCM_VECTORP (obj))
- return SCM_LENGTH (obj);
- else
- return -1;
- }
- else
- return -1;
-}
-
-
-SCM_PROC(s_length, "length", 1, 0, 0, scm_length);
-
-SCM
-scm_length(x)
- SCM x;
-{
- int i;
- i = scm_obj_length(x);
- if (i >= 0)
- return SCM_MAKINUM (i);
- else
- {
- SCM_ASSERT(0, x, SCM_ARG1, s_length);
- return SCM_BOOL_F;
- }
-}
-
-
-
-
-
-SCM_PROC (s_reverse, "reverse", 1, 0, 0, scm_reverse);
-
-SCM
-scm_reverse (objs)
- SCM objs;
-{
- return scm_list_reverse (objs);
-}
-
-
-
-
-
-void
-scm_init_sequences ()
-{
-#include "sequences.x"
-}
-
diff --git a/libguile/sequences.h b/libguile/sequences.h
deleted file mode 100644
index 6520457fc..000000000
--- a/libguile/sequences.h
+++ /dev/null
@@ -1,59 +0,0 @@
-/* classes: h_files */
-
-#ifndef SEQUENCESH
-#define SEQUENCESH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-
-
-
-
-
-extern int scm_obj_length SCM_P ((SCM obj));
-extern SCM scm_length SCM_P ((SCM x));
-extern SCM scm_reverse SCM_P ((SCM objs));
-extern void scm_init_sequences SCM_P ((void));
-
-#endif /* SEQUENCESH */
diff --git a/libguile/simpos.c b/libguile/simpos.c
deleted file mode 100644
index ee0f7a94d..000000000
--- a/libguile/simpos.c
+++ /dev/null
@@ -1,152 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-
-#include "scmsigs.h"
-#include "simpos.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-
-extern int system();
-
-
-#ifndef _Windows
-SCM_PROC(s_system, "system", 1, 0, 0, scm_system);
-
-SCM
-scm_system(cmd)
- SCM cmd;
-{
- SCM_ASSERT(SCM_NIMP(cmd) && SCM_ROSTRINGP(cmd), cmd, SCM_ARG1, s_system);
- if (SCM_ROSTRINGP (cmd))
- cmd = scm_makfromstr (SCM_ROCHARS (cmd), SCM_ROLENGTH (cmd), 0);
- scm_ignore_signals();
-# ifdef AZTEC_C
- cmd = SCM_MAKINUM(Execute(SCM_ROCHARS(cmd), 0, 0));
-# else
- cmd = SCM_MAKINUM(0L+system(SCM_ROCHARS(cmd)));
-# endif
- scm_unignore_signals();
- return cmd;
-}
-#endif
-
-extern char *getenv();
-SCM_PROC (s_getenv, "getenv", 1, 0, 0, scm_getenv);
-
-SCM
-scm_getenv(nam)
- SCM nam;
-{
- char *val;
- SCM_ASSERT(SCM_NIMP(nam) && SCM_ROSTRINGP(nam), nam, SCM_ARG1, s_getenv);
- if (SCM_ROSTRINGP (nam))
- nam = scm_makfromstr (SCM_ROCHARS (nam), SCM_ROLENGTH (nam), 0);
- val = getenv(SCM_CHARS(nam));
- return (val) ? scm_makfromstr(val, (scm_sizet)strlen(val), 0) : SCM_BOOL_F;
-}
-
-#ifdef vms
-# define SYSTNAME "VMS"
-#endif
-#ifdef unix
-# define SYSTNAME "UNIX"
-#endif
-#ifdef MWC
-# define SYSTNAME "COHERENT"
-#endif
-#ifdef _Windows
-# define SYSTNAME "WINDOWS"
-#else
-# ifdef MSDOS
-# define SYSTNAME "MS-DOS"
-# endif
-#endif
-#ifdef __EMX__
-# define SYSTNAME "OS/2"
-#endif
-#ifdef __IBMC__
-# define SYSTNAME "OS/2"
-#endif
-#ifdef THINK_C
-# define SYSTNAME "THINKC"
-#endif
-#ifdef AMIGA
-# define SYSTNAME "AMIGA"
-#endif
-#ifdef atarist
-# define SYSTNAME "ATARIST"
-#endif
-#ifdef mach
-# define SYSTNAME "MACH"
-#endif
-#ifdef ARM_ULIB
-# define SYSTNAME "ACORN"
-#endif
-
-SCM_PROC(s_software_type, "software-type", 0, 0, 0, scm_software_type);
-
-SCM
-scm_software_type()
-{
-#ifdef nosve
- return SCM_CAR(scm_intern("nosve", 5));
-#else
- return SCM_CAR(scm_intern(SYSTNAME, sizeof SYSTNAME/sizeof(char) -1));
-#endif
-}
-
-
-void
-scm_init_simpos ()
-{
-#include "simpos.x"
-}
-
diff --git a/libguile/simpos.h b/libguile/simpos.h
deleted file mode 100644
index 023966ad1..000000000
--- a/libguile/simpos.h
+++ /dev/null
@@ -1,55 +0,0 @@
-/* classes: h_files */
-
-#ifndef SIMPOSH
-#define SIMPOSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-
-extern SCM scm_system SCM_P ((SCM cmd));
-extern SCM scm_getenv SCM_P ((SCM nam));
-extern SCM scm_software_type SCM_P ((void));
-extern void scm_init_simpos SCM_P ((void));
-
-#endif /* SIMPOSH */
diff --git a/libguile/smob.c b/libguile/smob.c
deleted file mode 100644
index 90c27f6fe..000000000
--- a/libguile/smob.c
+++ /dev/null
@@ -1,129 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-
-#include "smob.h"
-
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-
-
-
-/* scm_smobs scm_numsmob
- * implement a dynamicly resized array of smob records.
- * Indexes into this table are used when generating type
- * tags for smobjects (if you know a tag you can get an index and conversely).
- */
-scm_sizet scm_numsmob;
-scm_smobfuns *scm_smobs;
-
-
-long
-scm_newsmob (smob)
- scm_smobfuns *smob;
-{
- char *tmp;
- if (255 <= scm_numsmob)
- goto smoberr;
- SCM_DEFER_INTS;
- SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_smobs, (1 + scm_numsmob) * sizeof (scm_smobfuns)));
- if (tmp)
- {
- scm_smobs = (scm_smobfuns *) tmp;
- scm_smobs[scm_numsmob].mark = smob->mark;
- scm_smobs[scm_numsmob].free = smob->free;
- scm_smobs[scm_numsmob].print = smob->print;
- scm_smobs[scm_numsmob].equalp = smob->equalp;
- scm_numsmob++;
- }
- SCM_ALLOW_INTS;
- if (!tmp)
- smoberr:scm_wta (SCM_MAKINUM ((long) scm_numsmob), (char *) SCM_NALLOC, "newsmob");
- return scm_tc7_smob + (scm_numsmob - 1) * 256;
-}
-
-/* {Initialization for i/o types, float, bignum, the type of free cells}
- */
-
-static scm_smobfuns freecell =
-{
- scm_mark0,
- scm_free0,
- 0,
- 0
-};
-
-static scm_smobfuns flob =
-{
- scm_mark0,
- /*flofree*/ 0,
- scm_floprint,
- scm_floequal
-};
-
-static scm_smobfuns bigob =
-{
- scm_mark0,
- /*bigfree*/ 0,
- scm_bigprint,
- scm_bigequal
-};
-
-
-
-
-void
-scm_smob_prehistory ()
-{
- scm_numsmob = 0;
- scm_smobs = (scm_smobfuns *) malloc (7 * sizeof (scm_smobfuns));
-
- /* WARNING: These scm_newsmob calls must be done in this order */
- scm_newsmob (&freecell);
- scm_newsmob (&flob);
- scm_newsmob (&bigob);
- scm_newsmob (&bigob); /* n.b.: two smobs, one smobfuns */
-}
-
diff --git a/libguile/smob.h b/libguile/smob.h
deleted file mode 100644
index cf5712fc7..000000000
--- a/libguile/smob.h
+++ /dev/null
@@ -1,78 +0,0 @@
-/* classes: h_files */
-
-#ifndef SMOBH
-#define SMOBH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-typedef struct scm_smobfuns
-{
- SCM (*mark) SCM_P ((SCM));
- scm_sizet (*free) SCM_P ((SCM));
- int (*print) SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
- SCM (*equalp) SCM_P ((SCM, SCM));
-} scm_smobfuns;
-
-
-
-#define SCM_SMOBNUM(x) (0x0ff & (SCM_CAR(x)>>8));
-#define SCM_PTOBNUM(x) (0x0ff & (SCM_CAR(x)>>8));
-
-extern scm_sizet scm_numsmob;
-extern scm_smobfuns *scm_smobs;
-
-
-
-/* Everyone who uses smobs needs to print. */
-#include "libguile/ports.h"
-#include "libguile/genio.h"
-
-/* ... and they all need to GC. */
-#include "libguile/markers.h"
-
-
-extern long scm_newsmob SCM_P ((scm_smobfuns *smob));
-extern void scm_smob_prehistory SCM_P ((void));
-
-#endif /* SMOBH */
diff --git a/libguile/snarf.h b/libguile/snarf.h
deleted file mode 100644
index 2104531aa..000000000
--- a/libguile/snarf.h
+++ /dev/null
@@ -1,94 +0,0 @@
-/* classes: h_files */
-
-/* Macros for snarfing initialization actions from C source. */
-
-#ifndef LIBGUILE_SNARF_H
-#define LIBGUILE_SNARF_H
-
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
-
-
-#ifndef SCM_MAGIC_SNARFER
-#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
- static char RANAME[]=STR
-#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
- static char RANAME[]=STR
-#else
-#ifdef __cplusplus
-#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
-%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, (SCM (*) (...)) CFN)
-#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
-%%% scm_make_subr(RANAME, TYPE, (SCM (*)(...)) CFN)
-#else /* not __cplusplus */
-#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
-%%% scm_make_gsubr (RANAME, REQ, OPT, VAR, CFN)
-#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
-%%% scm_make_subr(RANAME, TYPE, CFN)
-#endif /* not __cplusplus */
-#endif
-
-#ifndef SCM_MAGIC_SNARFER
-#define SCM_SYMBOL(c_name, scheme_name) \
- static SCM c_name = SCM_BOOL_F
-#else
-#define SCM_SYMBOL(C_NAME, SCHEME_NAME) \
-%%% C_NAME = scm_permanent_object (SCM_CAR (scm_intern0 (SCHEME_NAME)))
-#endif
-
-
-#ifndef SCM_MAGIC_SNARFER
-#define SCM_GLOBAL(c_name, scheme_name) \
- static SCM c_name = SCM_BOOL_F
-#else
-#define SCM_GLOBAL(C_NAME, SCHEME_NAME) \
-%%% C_NAME = scm_permanent_object (scm_intern0 (SCHEME_NAME)); SCM_SETCDR (C_NAME, SCM_BOOL_F)
-#endif
-
-
-#ifndef SCM_MAGIC_SNARFER
-#define SCM_CONST_LONG(C_NAME, SCHEME_NAME,VALUE) \
- static SCM C_NAME = SCM_BOOL_F
-#else
-#define SCM_CONST_LONG(C_NAME, SCHEME_NAME,VALUE) \
-%%% C_NAME = scm_permanent_object (scm_intern0 (SCHEME_NAME)); SCM_SETCDR (C_NAME, scm_long2num (VALUE))
-#endif
-
-#endif /* LIBGUILE_SNARF_H */
diff --git a/libguile/socket.c b/libguile/socket.c
deleted file mode 100644
index d28cd104e..000000000
--- a/libguile/socket.c
+++ /dev/null
@@ -1,398 +0,0 @@
-/* "socket.c" internet socket support for client/server in SCM
- * Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-/* Written in 1994 by Aubrey Jaffer.
- * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
- * Rewritten by Gary Houston to be a closer interface to the C socket library.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "feature.h"
-
-#include "socket.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-#include <sys/types.h>
-#include <sys/socket.h>
-#include <sys/un.h>
-#include <netinet/in.h>
-#include <netdb.h>
-#include <arpa/inet.h>
-
-
-
-#ifndef STDC_HEADERS
-int close ();
-#endif /* STDC_HEADERS */
-
-extern int inet_aton ();
-
-SCM_PROC (s_sys_inet_aton, "inet-aton", 1, 0, 0, scm_sys_inet_aton);
-
-SCM
-scm_sys_inet_aton (address)
- SCM address;
-{
- struct in_addr soka;
-
- SCM_ASSERT (SCM_NIMP (address) && SCM_ROSTRINGP (address), address, SCM_ARG1, s_sys_inet_aton);
- if (SCM_SUBSTRP (address))
- address = scm_makfromstr (SCM_ROCHARS (address), SCM_ROLENGTH (address), 0);
- if (inet_aton (SCM_ROCHARS (address), &soka) == 0)
- scm_syserror (s_sys_inet_aton);
- return scm_ulong2num (ntohl (soka.s_addr));
-}
-
-
-SCM_PROC (s_inet_ntoa, "inet-ntoa", 1, 0, 0, scm_inet_ntoa);
-
-SCM
-scm_inet_ntoa (inetid)
- SCM inetid;
-{
- struct in_addr addr;
- char *s;
- SCM answer;
- addr.s_addr = htonl (scm_num2ulong (inetid, (char *) SCM_ARG1, s_inet_ntoa));
- SCM_DEFER_INTS;
- s = inet_ntoa (addr);
- answer = scm_makfromstr (s, strlen (s), 0);
- SCM_ALLOW_INTS;
- return answer;
-}
-
-SCM_PROC (s_inet_netof, "inet-netof", 1, 0, 0, scm_inet_netof);
-
-SCM
-scm_inet_netof (address)
- SCM address;
-{
- struct in_addr addr;
- addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_inet_netof));
- return scm_ulong2num ((unsigned long) inet_netof (addr));
-}
-
-SCM_PROC (s_lnaof, "lnaof", 1, 0, 0, scm_lnaof);
-
-SCM
-scm_lnaof (address)
- SCM address;
-{
- struct in_addr addr;
- addr.s_addr = htonl (scm_num2ulong (address, (char *) SCM_ARG1, s_lnaof));
- return scm_ulong2num ((unsigned long) inet_lnaof (addr));
-}
-
-
-SCM_PROC (s_inet_makeaddr, "inet-makeaddr", 2, 0, 0, scm_inet_makeaddr);
-
-SCM
-scm_inet_makeaddr (net, lna)
- SCM net;
- SCM lna;
-{
- struct in_addr addr;
- unsigned long netnum;
- unsigned long lnanum;
-
- netnum = scm_num2ulong (net, (char *) SCM_ARG1, s_inet_makeaddr);
- lnanum = scm_num2ulong (lna, (char *) SCM_ARG2, s_inet_makeaddr);
- addr = inet_makeaddr (netnum, lnanum);
- return scm_ulong2num (ntohl (addr.s_addr));
-}
-
-
-/* !!! Doesn't take address format.
- * Assumes hostent stream isn't reused.
- */
-
-SCM_PROC (s_sys_gethost, "gethost", 0, 1, 0, scm_sys_gethost);
-
-SCM
-scm_sys_gethost (name)
- SCM name;
-{
- SCM ans = scm_make_vector (SCM_MAKINUM (5), SCM_UNSPECIFIED, SCM_BOOL_F);
- SCM *ve = SCM_VELTS (ans);
- SCM lst = SCM_EOL;
- struct hostent *entry;
- struct in_addr inad;
- char **argv;
- int i = 0;
-#ifdef HAVE_GETHOSTENT
- if (SCM_UNBNDP (name))
- {
- SCM_DEFER_INTS;
- entry = gethostent ();
- }
- else
-#endif
- if (SCM_NIMP (name) && SCM_STRINGP (name))
- {
- SCM_DEFER_INTS;
- entry = gethostbyname (SCM_CHARS (name));
- }
- else
- {
- inad.s_addr = htonl (scm_num2ulong (name, (char *) SCM_ARG1, s_sys_gethost));
- SCM_DEFER_INTS;
- entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
- }
- SCM_ALLOW_INTS;
- if (!entry)
- scm_syserror (s_sys_gethost);
- ve[0] = scm_makfromstr (entry->h_name, (scm_sizet) strlen (entry->h_name), 0);
- ve[1] = scm_makfromstrs (-1, entry->h_aliases);
- ve[2] = SCM_MAKINUM (entry->h_addrtype + 0L);
- ve[3] = SCM_MAKINUM (entry->h_length + 0L);
- if (sizeof (struct in_addr) != entry->h_length)
- {
- ve[4] = SCM_BOOL_F;
- return ans;
- }
- for (argv = entry->h_addr_list; argv[i]; i++);
- while (i--)
- {
- inad = *(struct in_addr *) argv[i];
- lst = scm_cons (scm_ulong2num (ntohl (inad.s_addr)), lst);
- }
- ve[4] = lst;
- return ans;
-}
-
-
-SCM_PROC (s_sys_getnet, "getnet", 0, 1, 0, scm_sys_getnet);
-
-SCM
-scm_sys_getnet (name)
- SCM name;
-{
- SCM ans;
- SCM *ve;
- struct netent *entry;
-
- ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
- ve = SCM_VELTS (ans);
- if (SCM_UNBNDP (name))
- {
- SCM_DEFER_INTS;
- entry = getnetent ();
- }
- else if (SCM_NIMP (name) && SCM_STRINGP (name))
- {
- SCM_DEFER_INTS;
- entry = getnetbyname (SCM_CHARS (name));
- }
- else
- {
- unsigned long netnum;
- netnum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getnet);
- SCM_DEFER_INTS;
- entry = getnetbyaddr (netnum, AF_INET);
- }
- SCM_ALLOW_INTS;
- if (!entry)
- scm_syserror (s_sys_getnet);
- ve[0] = scm_makfromstr (entry->n_name, (scm_sizet) strlen (entry->n_name), 0);
- ve[1] = scm_makfromstrs (-1, entry->n_aliases);
- ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L);
- ve[3] = scm_ulong2num (entry->n_net + 0L);
- return ans;
-}
-
-SCM_PROC (s_sys_getproto, "getproto", 0, 1, 0, scm_sys_getproto);
-
-SCM
-scm_sys_getproto (name)
- SCM name;
-{
- SCM ans;
- SCM *ve;
- struct protoent *entry;
-
- ans = scm_make_vector (SCM_MAKINUM (3), SCM_UNSPECIFIED, SCM_BOOL_F);
- ve = SCM_VELTS (ans);
- if (SCM_UNBNDP (name))
- {
- SCM_DEFER_INTS;
- entry = getprotoent ();
- }
- else if (SCM_NIMP (name) && SCM_STRINGP (name))
- {
- SCM_DEFER_INTS;
- entry = getprotobyname (SCM_CHARS (name));
- }
- else
- {
- unsigned long protonum;
- protonum = scm_num2ulong (name, (char *) SCM_ARG1, s_sys_getproto);
- SCM_DEFER_INTS;
- entry = getprotobynumber (protonum);
- }
- SCM_ALLOW_INTS;
- if (!entry)
- scm_syserror (s_sys_getproto);
- ve[0] = scm_makfromstr (entry->p_name, (scm_sizet) strlen (entry->p_name), 0);
- ve[1] = scm_makfromstrs (-1, entry->p_aliases);
- ve[2] = SCM_MAKINUM (entry->p_proto + 0L);
- return ans;
-}
-
-
-static SCM scm_return_entry SCM_P ((struct servent *entry));
-
-static SCM
-scm_return_entry (entry)
- struct servent *entry;
-{
- SCM ans;
- SCM *ve;
-
- ans = scm_make_vector (SCM_MAKINUM (4), SCM_UNSPECIFIED, SCM_BOOL_F);
- ve = SCM_VELTS (ans);
- ve[0] = scm_makfromstr (entry->s_name, (scm_sizet) strlen (entry->s_name), 0);
- ve[1] = scm_makfromstrs (-1, entry->s_aliases);
- ve[2] = SCM_MAKINUM (ntohs (entry->s_port) + 0L);
- ve[3] = scm_makfromstr (entry->s_proto, (scm_sizet) strlen (entry->s_proto), 0);
- SCM_ALLOW_INTS;
- return ans;
-}
-
-SCM_PROC (s_sys_getserv, "getserv", 0, 2, 0, scm_sys_getserv);
-
-SCM
-scm_sys_getserv (name, proto)
- SCM name;
- SCM proto;
-{
- struct servent *entry;
- if (SCM_UNBNDP (name))
- {
- SCM_DEFER_INTS;
- entry = getservent ();
- if (!entry)
- scm_syserror (s_sys_getserv);
- return scm_return_entry (entry);
- }
- SCM_ASSERT (SCM_NIMP (proto) && SCM_STRINGP (proto), proto, SCM_ARG2, s_sys_getserv);
- if (SCM_NIMP (name) && SCM_STRINGP (name))
- {
- SCM_DEFER_INTS;
- entry = getservbyname (SCM_CHARS (name), SCM_CHARS (proto));
- }
- else
- {
- SCM_ASSERT (SCM_INUMP (name), name, SCM_ARG1, s_sys_getserv);
- SCM_DEFER_INTS;
- entry = getservbyport (SCM_INUM (name), SCM_CHARS (proto));
- }
- if (!entry)
- scm_syserror (s_sys_getserv);
- return scm_return_entry (entry);
-}
-
-SCM_PROC (s_sethost, "sethost", 0, 1, 0, scm_sethost);
-
-SCM
-scm_sethost (arg)
- SCM arg;
-{
- if (SCM_UNBNDP (arg))
- endhostent ();
- else
- sethostent (SCM_NFALSEP (arg));
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_setnet, "setnet", 0, 1, 0, scm_setnet);
-
-SCM
-scm_setnet (arg)
- SCM arg;
-{
- if (SCM_UNBNDP (arg))
- endnetent ();
- else
- setnetent (SCM_NFALSEP (arg));
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_setproto, "setproto", 0, 1, 0, scm_setproto);
-
-SCM
-scm_setproto (arg)
- SCM arg;
-{
- if (SCM_UNBNDP (arg))
- endprotoent ();
- else
- setprotoent (SCM_NFALSEP (arg));
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_setserv, "setserv", 0, 1, 0, scm_setserv);
-
-SCM
-scm_setserv (arg)
- SCM arg;
-{
- if (SCM_UNBNDP (arg))
- endservent ();
- else
- setservent (SCM_NFALSEP (arg));
- return SCM_UNSPECIFIED;
-}
-
-
-void
-scm_init_socket ()
-{
- scm_add_feature ("socket");
-#include "socket.x"
-}
-
-
diff --git a/libguile/socket.h b/libguile/socket.h
deleted file mode 100644
index b87afb18f..000000000
--- a/libguile/socket.h
+++ /dev/null
@@ -1,69 +0,0 @@
-/* classes: h_files */
-
-#ifndef SOCKETH
-#define SOCKETH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-
-
-
-extern SCM scm_sys_gethost SCM_P ((SCM name));
-extern SCM scm_sys_inet_aton SCM_P ((SCM address));
-extern SCM scm_inet_ntoa SCM_P ((SCM inetid));
-extern SCM scm_inet_netof SCM_P ((SCM address));
-extern SCM scm_lnaof SCM_P ((SCM address));
-extern SCM scm_inet_makeaddr SCM_P ((SCM net, SCM lna));
-extern SCM scm_sys_getnet SCM_P ((SCM name));
-extern SCM scm_sys_getproto SCM_P ((SCM name));
-extern SCM scm_sys_getserv SCM_P ((SCM name, SCM proto));
-extern SCM scm_sethost SCM_P ((SCM arg));
-extern SCM scm_setnet SCM_P ((SCM arg));
-extern SCM scm_setproto SCM_P ((SCM arg));
-extern SCM scm_setserv SCM_P ((SCM arg));
-extern void scm_init_socket SCM_P ((void));
-
-#endif /* SOCKETH */
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
deleted file mode 100644
index 86705826f..000000000
--- a/libguile/srcprop.c
+++ /dev/null
@@ -1,363 +0,0 @@
-/* Copyright (C) 1995,1996 Mikael Djurfeldt
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- *
- * The author can be reached at djurfeldt@nada.kth.se
- * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "smob.h"
-#include "alist.h"
-#include "debug.h"
-#include "hashtab.h"
-#include "hash.h"
-#include "weaks.h"
-
-#include "srcprop.h"
-
-/* {Source Properties}
- *
- * Properties of source list expressions.
- * Five of these have special meaning and optimized storage:
- *
- * filename string The name of the source file.
- * copy list A copy of the list expression.
- * line integer The source code line number.
- * column integer The source code column number.
- * breakpoint boolean Sets a breakpoint on this form.
- *
- * Most properties above can be set by the reader.
- *
- */
-
-SCM scm_i_filename;
-SCM scm_i_copy;
-SCM scm_i_line;
-SCM scm_i_column;
-SCM scm_i_breakpoint;
-
-long scm_tc16_srcprops;
-static scm_srcprops_chunk *srcprops_chunklist = 0;
-static scm_srcprops *srcprops_freelist = 0;
-
-
-static SCM marksrcprops SCM_P ((SCM obj));
-
-static SCM
-marksrcprops (obj)
- SCM obj;
-{
- SCM_SETGC8MARK (obj);
- scm_gc_mark (SRCPROPFNAME (obj));
- scm_gc_mark (SRCPROPCOPY (obj));
- return SRCPROPPLIST (obj);
-}
-
-
-static scm_sizet freesrcprops SCM_P ((SCM obj));
-
-static scm_sizet
-freesrcprops (obj)
- SCM obj;
-{
- *((scm_srcprops **) SCM_CDR (obj)) = srcprops_freelist;
- srcprops_freelist = (scm_srcprops *) SCM_CDR (obj);
- return 0; /* srcprops_chunks are not freed until leaving guile */
-}
-
-
-static int prinsrcprops SCM_P ((SCM obj, SCM port, scm_print_state *pstate));
-
-static int
-prinsrcprops (obj, port, pstate)
- SCM obj;
- SCM port;
- scm_print_state *pstate;
-{
- int writingp = SCM_WRITINGP (pstate);
- scm_gen_puts (scm_regular_string, "#<srcprops ", port);
- SCM_SET_WRITINGP (pstate, 1);
- scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate);
- SCM_SET_WRITINGP (pstate, writingp);
- scm_gen_putc ('>', port);
- return 1;
-}
-
-static scm_smobfuns srcpropssmob =
-{marksrcprops, freesrcprops, prinsrcprops, 0};
-
-
-SCM
-scm_make_srcprops (line, col, filename, copy, plist)
- int line;
- int col;
- SCM filename;
- SCM copy;
- SCM plist;
-{
- register SCM ans;
- register scm_srcprops *ptr;
- SCM_DEFER_INTS;
- if ((ptr = srcprops_freelist) != NULL)
- srcprops_freelist = *(scm_srcprops **)ptr;
- else
- {
- int i;
- scm_srcprops_chunk *mem;
- scm_sizet n = sizeof (scm_srcprops_chunk)
- + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
- SCM_SYSCALL (mem = (scm_srcprops_chunk *) malloc (n));
- SCM_ASSERT (mem, SCM_UNDEFINED, SCM_NALLOC, "srcprops");
- scm_mallocated += n;
- mem->next = srcprops_chunklist;
- srcprops_chunklist = mem;
- ptr = &mem->srcprops[0];
- for (i = 1; i < SRCPROPS_CHUNKSIZE - 1; ++i)
- *(scm_srcprops **)&ptr[i] = &ptr[i + 1];
- *(scm_srcprops **)&ptr[SRCPROPS_CHUNKSIZE - 1] = 0;
- srcprops_freelist = (scm_srcprops *) &ptr[1];
- }
- SCM_NEWCELL (ans);
- SCM_SETCAR (ans, scm_tc16_srcprops);
- ptr->pos = SRCPROPMAKPOS (line, col);
- ptr->fname = filename;
- ptr->copy = copy;
- ptr->plist = plist;
- SCM_SETCDR (ans, (SCM) ptr);
- SCM_ALLOW_INTS;
- return ans;
-}
-
-
-SCM
-scm_srcprops_to_plist (obj)
- SCM obj;
-{
- SCM plist = SRCPROPPLIST (obj);
- if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
- plist = scm_acons (scm_i_copy, SRCPROPCOPY (obj), plist);
- if (!SCM_UNBNDP (SRCPROPFNAME (obj)))
- plist = scm_acons (scm_i_filename, SRCPROPFNAME (obj), plist);
- plist = scm_acons (scm_i_column, SCM_MAKINUM (SRCPROPCOL (obj)), plist);
- plist = scm_acons (scm_i_line, SCM_MAKINUM (SRCPROPLINE (obj)), plist);
- plist = scm_acons (scm_i_breakpoint, SRCPROPBRK (obj), plist);
- return plist;
-}
-
-SCM_PROC (s_source_properties, "source-properties", 1, 0, 0, scm_source_properties);
-
-SCM
-scm_source_properties (obj)
- SCM obj;
-{
- SCM p;
- SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_properties);
- if (SCM_MEMOIZEDP (obj))
- obj = SCM_MEMOIZED_EXP (obj);
-#ifndef SCM_RECKLESS
- else if (SCM_NCONSP (obj))
- scm_wrong_type_arg (s_source_properties, 1, obj);
-#endif
- p = scm_hashq_ref (scm_source_whash, obj, (SCM) NULL);
- if (p != (SCM) NULL && SRCPROPSP (p))
- return scm_srcprops_to_plist (p);
- return SCM_EOL;
-}
-
-/* Perhaps this procedure should look through an alist
- and try to make a srcprops-object...? */
-SCM_PROC (s_set_source_properties_x, "set-source-properties!", 2, 0, 0, scm_set_source_properties_x);
-
-SCM
-scm_set_source_properties_x (obj, plist)
- SCM obj;
- SCM plist;
-{
- SCM handle;
- SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_properties_x);
- if (SCM_MEMOIZEDP (obj))
- obj = SCM_MEMOIZED_EXP (obj);
-#ifndef SCM_RECKLESS
- else if (SCM_NCONSP (obj))
- scm_wrong_type_arg (s_set_source_properties_x, 1, obj);
-#endif
- handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist);
- SCM_SETCDR (handle, plist);
- return plist;
-}
-
-SCM_PROC (s_source_property, "source-property", 2, 0, 0, scm_source_property);
-
-SCM
-scm_source_property (obj, key)
- SCM obj;
- SCM key;
-{
- SCM p;
- SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_source_property);
- if (SCM_MEMOIZEDP (obj))
- obj = SCM_MEMOIZED_EXP (obj);
-#ifndef SCM_RECKLESS
- else if (SCM_NCONSP (obj))
- scm_wrong_type_arg (s_source_property, 1, obj);
-#endif
- p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
- if (SCM_IMP (p) || !SRCPROPSP (p))
- goto plist;
- if (scm_i_breakpoint == key) p = SRCPROPBRK (p);
- else if (scm_i_line == key) p = SCM_MAKINUM (SRCPROPLINE (p));
- else if (scm_i_column == key) p = SCM_MAKINUM (SRCPROPCOL (p));
- else if (scm_i_filename == key) p = SRCPROPFNAME (p);
- else if (scm_i_copy == key) p = SRCPROPCOPY (p);
- else
- {
- p = SRCPROPPLIST (p);
- plist:
- p = scm_assoc (key, p);
- return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
- }
- return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
-}
-
-SCM_PROC (s_set_source_property_x, "set-source-property!", 3, 0, 0, scm_set_source_property_x);
-
-SCM
-scm_set_source_property_x (obj, key, datum)
- SCM obj;
- SCM key;
- SCM datum;
-{
- scm_whash_handle h;
- SCM p;
- SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_set_source_property_x);
- if (SCM_MEMOIZEDP (obj))
- obj = SCM_MEMOIZED_EXP (obj);
-#ifndef SCM_RECKLESS
- else if (SCM_NCONSP (obj))
- scm_wrong_type_arg (s_set_source_property_x, 1, obj);
-#endif
- h = scm_whash_get_handle (scm_source_whash, obj);
- if (SCM_WHASHFOUNDP (h))
- p = SCM_WHASHREF (scm_source_whash, h);
- else
- {
- h = scm_whash_create_handle (scm_source_whash, obj);
- p = SCM_EOL;
- }
- if (scm_i_breakpoint == key)
- if (SCM_FALSEP (datum))
- CLEARSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
- ? p
- : SCM_WHASHSET (scm_source_whash, h,
- scm_make_srcprops (0, 0, SCM_UNDEFINED,
- SCM_UNDEFINED, p)));
- else
- SETSRCPROPBRK (SCM_NIMP (p) && SRCPROPSP (p)
- ? p
- : SCM_WHASHSET (scm_source_whash, h,
- scm_make_srcprops (0, 0, SCM_UNDEFINED,
- SCM_UNDEFINED, p)));
- else if (scm_i_line == key)
- {
- if (SCM_NIMP (p) && SRCPROPSP (p))
- SETSRCPROPLINE (p, datum);
- else
- SCM_WHASHSET (scm_source_whash, h,
- scm_make_srcprops (datum, 0, SCM_UNDEFINED, SCM_UNDEFINED, p));
- }
- else if (scm_i_column == key)
- {
- if (SCM_NIMP (p) && SRCPROPSP (p))
- SETSRCPROPCOL (p, datum);
- else
- SCM_WHASHSET (scm_source_whash, h,
- scm_make_srcprops (0, datum, SCM_UNDEFINED, SCM_UNDEFINED, p));
- }
- else if (scm_i_filename == key)
- {
- if (SCM_NIMP (p) && SRCPROPSP (p))
- SRCPROPFNAME (p) = datum;
- else
- SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, datum, SCM_UNDEFINED, p));
- }
- else if (scm_i_filename == key)
- {
- if (SCM_NIMP (p) && SRCPROPSP (p))
- SRCPROPCOPY (p) = datum;
- else
- SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
- }
- else
- SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
- return SCM_UNSPECIFIED;
-}
-
-
-void
-scm_init_srcprop ()
-{
- scm_tc16_srcprops = scm_newsmob (&srcpropssmob);
- scm_source_whash = scm_make_weak_key_hash_table (SCM_MAKINUM (2047));
-
- scm_i_filename = SCM_CAR (scm_sysintern ("filename", SCM_UNDEFINED));
- scm_i_copy = SCM_CAR (scm_sysintern ("copy", SCM_UNDEFINED));
- scm_i_line = SCM_CAR (scm_sysintern ("line", SCM_UNDEFINED));
- scm_i_column = SCM_CAR (scm_sysintern ("column", SCM_UNDEFINED));
- scm_i_breakpoint = SCM_CAR (scm_sysintern ("breakpoint", SCM_UNDEFINED));
-
- scm_sysintern ("source-whash", scm_source_whash);
-#include "srcprop.x"
-}
-
-void
-scm_finish_srcprop ()
-{
- register scm_srcprops_chunk *ptr = srcprops_chunklist, *next;
- while (ptr)
- {
- next = ptr->next;
- free ((char *) ptr);
- scm_mallocated -= sizeof (scm_srcprops_chunk)
- + sizeof (scm_srcprops) * (SRCPROPS_CHUNKSIZE - 1);
- ptr = next;
- }
-}
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
deleted file mode 100644
index ae9358b0c..000000000
--- a/libguile/srcprop.h
+++ /dev/null
@@ -1,134 +0,0 @@
-/* classes: h_files */
-
-#ifndef SRCPROPH
-#define SRCPROPH
-/* Copyright (C) 1995,1996 Mikael Djurfeldt
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- *
- * The author can be reached at djurfeldt@nada.kth.se
- * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-/* {The old whash table interface}
- * *fixme* This is a temporary solution until weak hash table access
- * has been optimized for speed (which is quite necessary, if they are
- * used for recording of source code positions...)
- */
-
-#define scm_whash_handle SCM
-
-#define scm_whash_get_handle(whash, key) scm_hash_fn_get_handle (whash, key, scm_ihashq, scm_sloppy_assq, 0)
-#define SCM_WHASHFOUNDP(h) ((h) != SCM_BOOL_F)
-#define SCM_WHASHREF(whash, handle) SCM_CDR (handle)
-#define SCM_WHASHSET(whash, handle, obj) SCM_SETCDR (handle, obj)
-#define scm_whash_create_handle(whash, key) scm_hash_fn_create_handle_x (whash, key, SCM_UNSPECIFIED, scm_ihashq, scm_sloppy_assq, 0)
-#define scm_whash_lookup(whash, obj) scm_hash_fn_ref (whash, obj, SCM_BOOL_F, scm_ihashq, scm_sloppy_assq, 0)
-#define scm_whash_insert(whash, key, obj) \
-{ \
- register SCM w = (whash); \
- SCM_WHASHSET (w, scm_whash_create_handle (w, key), obj); \
-} \
-
-
-/* {Source properties}
- */
-
-extern long scm_tc16_srcprops;
-
-typedef struct scm_srcprops
-{
- unsigned long pos;
- SCM fname;
- SCM copy;
- SCM plist;
-} scm_srcprops;
-
-#define SRCPROPS_CHUNKSIZE 2047 /* Number of srcprops per chunk */
-typedef struct scm_srcprops_chunk
-{
- struct scm_srcprops_chunk *next;
- scm_srcprops srcprops[1];
-} scm_srcprops_chunk;
-
-#define SRCPROPSP(p) (SCM_TYP16 (p) == scm_tc16_srcprops)
-#define SRCPROPBRK(p) ((1L << 16) & SCM_CAR (p) ? SCM_BOOL_T : SCM_BOOL_F)
-#define SRCPROPPOS(p) ((scm_srcprops *) SCM_CDR (p))->pos
-#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
-#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
-#define SRCPROPFNAME(p) ((scm_srcprops *) SCM_CDR (p))->fname
-#define SRCPROPCOPY(p) ((scm_srcprops *) SCM_CDR (p))->copy
-#define SRCPROPPLIST(p) ((scm_srcprops *) SCM_CDR (p))->plist
-#define SETSRCPROPBRK(p) (SCM_SETOR_CAR (p, (1L << 16)))
-#define CLEARSRCPROPBRK(p) SCM_SETAND_CAR (p, ~(1L << 16))
-#define SRCPROPMAKPOS(l,c) (((l) << 12) + (c))
-#define SETSRCPROPPOS(p,l,c) (SRCPROPPOS (p) = SRCPROPMAKPOS (l, c))
-#define SETSRCPROPLINE(p,l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
-#define SETSRCPROPCOL(p,c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
-
-#define SRCBRKP(x) (SCM_NIMP (t.arg1 = scm_whash_lookup (scm_source_whash, (x)))\
- && SRCPROPSP (t.arg1)\
- && (1L << 16) & SCM_CAR (t.arg1))
-
-#define PROCTRACEP(x) SCM_NFALSEP (scm_procedure_property (x, scm_i_trace))
-
-extern SCM scm_i_filename;
-extern SCM scm_i_copy;
-extern SCM scm_i_line;
-extern SCM scm_i_column;
-extern SCM scm_i_breakpoint;
-
-
-
-
-extern SCM scm_srcprops_to_plist SCM_P ((SCM obj));
-extern SCM scm_make_srcprops SCM_P ((int line, int col, SCM fname, SCM copy, SCM plist));
-extern SCM scm_source_property SCM_P ((SCM obj, SCM key));
-extern SCM scm_set_source_property_x SCM_P ((SCM obj, SCM key, SCM datum));
-extern SCM scm_source_properties SCM_P ((SCM obj));
-extern SCM scm_set_source_properties_x SCM_P ((SCM obj, SCM props));
-extern void scm_finish_srcprop SCM_P ((void));
-extern void scm_init_srcprop SCM_P ((void));
-
-#endif /* SRCPROPH */
diff --git a/libguile/stackchk.c b/libguile/stackchk.c
deleted file mode 100644
index 92846170f..000000000
--- a/libguile/stackchk.c
+++ /dev/null
@@ -1,104 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "genio.h"
-
-#include "stackchk.h"
-
-
-/* {Stack Checking}
- */
-
-#ifdef STACK_CHECKING
-int scm_stack_checking_enabled_p;
-
-SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
-
-void
-scm_report_stack_overflow ()
-{
- scm_stack_checking_enabled_p = 0;
- scm_error (scm_stack_overflow_key,
- NULL,
- "Stack overflow",
- SCM_BOOL_F,
- SCM_BOOL_F);
-}
-
-#endif
-
-long
-scm_stack_size (start)
- SCM_STACKITEM *start;
-{
- SCM_STACKITEM stack;
-#ifdef SCM_STACK_GROWS_UP
- return &stack - start;
-#else
- return start - &stack;
-#endif /* def SCM_STACK_GROWS_UP */
-}
-
-
-void
-scm_stack_report ()
-{
- SCM_STACKITEM stack;
- scm_intprint (scm_stack_size (SCM_BASE (scm_rootcont)) * sizeof (SCM_STACKITEM),
- 16, scm_cur_errp);
- scm_gen_puts (scm_regular_string, " of stack: 0x", scm_cur_errp);
- scm_intprint ((long) SCM_BASE (scm_rootcont), 16, scm_cur_errp);
- scm_gen_puts (scm_regular_string, " - 0x", scm_cur_errp);
- scm_intprint ((long) &stack, 16, scm_cur_errp);
- scm_gen_puts (scm_regular_string, "\n", scm_cur_errp);
-}
-
-
-
-
-void
-scm_init_stackchk ()
-{
-#include "stackchk.x"
-}
diff --git a/libguile/stackchk.h b/libguile/stackchk.h
deleted file mode 100644
index 6e6a358fc..000000000
--- a/libguile/stackchk.h
+++ /dev/null
@@ -1,92 +0,0 @@
-/* classes: h_files */
-
-#ifndef STACKCHKH
-#define STACKCHKH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-#include "libguile/continuations.h"
-#ifdef DEBUG_EXTENSIONS
-#include "libguile/debug.h"
-#endif
-
-
-/* With debug extensions we have the possibility to use the debug options
- * to disable stack checking.
- */
-#ifdef DEBUG_EXTENSIONS
-#define SCM_STACK_CHECKING_P SCM_STACK_LIMIT
-#else
-/* *fixme* This option should be settable also without debug extensions. */
-#define SCM_STACK_LIMIT 100000
-#define SCM_STACK_CHECKING_P 1
-#endif
-
-#ifdef STACK_CHECKING
-# ifdef SCM_STACK_GROWS_UP
-# define SCM_STACK_OVERFLOW_P(s)\
- (s - SCM_BASE (scm_rootcont) > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM))
-# else
-# define SCM_STACK_OVERFLOW_P(s)\
- (SCM_BASE (scm_rootcont) - s > SCM_STACK_LIMIT * sizeof (SCM_STACKITEM))
-# endif
-# define SCM_CHECK_STACK\
- {\
- SCM_STACKITEM stack;\
- if (SCM_STACK_OVERFLOW_P (&stack) && scm_stack_checking_enabled_p)\
- scm_report_stack_overflow ();\
- }
-#else
-# define SCM_CHECK_STACK /**/
-#endif /* STACK_CHECKING */
-
-extern int scm_stack_checking_enabled_p;
-
-
-
-extern void scm_report_stack_overflow SCM_P ((void));
-extern long scm_stack_size SCM_P ((SCM_STACKITEM *start));
-extern void scm_stack_report SCM_P ((void));
-extern void scm_init_stackchk SCM_P ((void));
-
-#endif /* STACKCHKH */
diff --git a/libguile/stacks.h b/libguile/stacks.h
deleted file mode 100644
index 3cbcb28be..000000000
--- a/libguile/stacks.h
+++ /dev/null
@@ -1,135 +0,0 @@
-/* classes: h_files */
-
-#ifndef STACKSH
-#define STACKSH
-/* Copyright (C) 1995,1996 Mikael Djurfeldt
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- *
- * The author can be reached at djurfeldt@nada.kth.se
- * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
- */
-
-
-#include "libguile/__scm.h"
-
-/* {Frames and stacks}
- */
-
-typedef struct scm_info_frame {
- SCM flags;
- SCM source;
- SCM proc;
- SCM args;
-} scm_info_frame;
-#define SCM_FRAME_N_SLOTS (sizeof (scm_info_frame) / sizeof (SCM))
-
-#define SCM_STACK(obj) ((scm_stack *) SCM_STRUCT_DATA (obj))
-#define SCM_STACK_LAYOUT "pwuourpW"
-typedef struct scm_stack {
- SCM id; /* Stack id */
- scm_info_frame *frames; /* Info frames */
- unsigned int length; /* Stack length */
- unsigned int tail_length;
- scm_info_frame tail[1];
-} scm_stack;
-
-extern SCM scm_stack_type;
-
-#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE (obj) == scm_stack_type)
-#define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length)
-
-#define SCM_FRAMEP(obj) (SCM_CONSP (obj) \
- && SCM_NIMP (SCM_CAR (obj)) \
- && SCM_STACKP (SCM_CAR (obj)) \
- && SCM_INUMP (SCM_CDR (obj))) \
-
-
-#define SCM_FRAME_REF(frame, slot) \
-(SCM_STACK (SCM_CAR (frame)) -> frames[SCM_INUM (SCM_CDR (frame))].slot) \
-
-#define SCM_FRAME_NUMBER(frame) \
-(SCM_BACKWARDS_P \
- ? SCM_INUM (SCM_CDR (frame)) \
- : (SCM_STACK_LENGTH (SCM_CAR (frame)) \
- - SCM_INUM (SCM_CDR (frame)) \
- - 1)) \
-
-#define SCM_FRAME_FLAGS(frame) SCM_FRAME_REF (frame, flags)
-#define SCM_FRAME_SOURCE(frame) SCM_FRAME_REF (frame, source)
-#define SCM_FRAME_PROC(frame) SCM_FRAME_REF (frame, proc)
-#define SCM_FRAME_ARGS(frame) SCM_FRAME_REF (frame, args)
-#define SCM_FRAME_PREV(frame) scm_frame_previous (frame)
-#define SCM_FRAME_NEXT(frame) scm_frame_next (frame)
-
-#define SCM_FRAMEF_VOID (1L << 2)
-#define SCM_FRAMEF_REAL (1L << 3)
-#define SCM_FRAMEF_PROC (1L << 4)
-#define SCM_FRAMEF_EVAL_ARGS (1L << 5)
-#define SCM_FRAMEF_OVERFLOW (1L << 6)
-
-#define SCM_FRAME_VOID_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_VOID)
-#define SCM_FRAME_REAL_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_REAL)
-#define SCM_FRAME_PROC_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_PROC)
-#define SCM_FRAME_EVAL_ARGS_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_EVAL_ARGS)
-#define SCM_FRAME_OVERFLOW_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_OVERFLOW)
-
-
-
-SCM scm_stack_p SCM_P ((SCM obj));
-SCM scm_make_stack SCM_P ((SCM args));
-SCM scm_stack_ref SCM_P ((SCM stack, SCM i));
-SCM scm_stack_length SCM_P ((SCM stack));
-
-SCM scm_frame_p SCM_P ((SCM obj));
-SCM scm_last_stack_frame SCM_P ((SCM obj));
-SCM scm_frame_number SCM_P ((SCM frame));
-SCM scm_frame_source SCM_P ((SCM frame));
-SCM scm_frame_procedure SCM_P ((SCM frame));
-SCM scm_frame_arguments SCM_P ((SCM frame));
-SCM scm_frame_previous SCM_P ((SCM frame));
-SCM scm_frame_next SCM_P ((SCM frame));
-SCM scm_frame_real_p SCM_P ((SCM frame));
-SCM scm_frame_procedure_p SCM_P ((SCM frame));
-SCM scm_frame_evaluating_args_p SCM_P ((SCM frame));
-SCM scm_frame_overflow_p SCM_P ((SCM frame));
-
-void scm_init_stacks SCM_P ((void));
-
-#endif /* STACKSH */
diff --git a/libguile/stamp-h.in b/libguile/stamp-h.in
deleted file mode 100644
index e69de29bb..000000000
--- a/libguile/stamp-h.in
+++ /dev/null
diff --git a/libguile/stime.c b/libguile/stime.c
deleted file mode 100644
index efc9d172f..000000000
--- a/libguile/stime.c
+++ /dev/null
@@ -1,206 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-
-#include "stime.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-
-# ifdef HAVE_SYS_TYPES_H
-# include <sys/types.h>
-# endif
-
-# ifdef TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-# else
-# ifdef HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# ifdef HAVE_TIME_H
-# include <time.h>
-# endif
-# endif
-# endif
-
-# ifdef HAVE_SYS_TIMES_H
-# include <sys/times.h>
-# else
-# ifdef HAVE_SYS_TIMEB_H
-# include <sys/timeb.h>
-# endif
-# endif
-
-#ifdef CLK_TCK
-# define CLKTCK CLK_TCK
-# ifdef CLOCKS_PER_SEC
-# ifdef unix
-# ifndef ARM_ULIB
-# include <sys/times.h>
-# endif
-# define LACK_CLOCK
- /* This is because clock() might be POSIX rather than ANSI.
- This occurs on HP-UX machines */
-# endif
-# endif
-#else
-# ifdef CLOCKS_PER_SEC
-# define CLKTCK CLOCKS_PER_SEC
-# else
-# define LACK_CLOCK
-# define CLKTCK 60
-# endif
-#endif
-
-
-# ifdef HAVE_FTIME
-# include <sys/timeb.h>
-# endif
-
-
-#ifdef __STDC__
-# define timet time_t
-#else
-# define timet long
-#endif
-
-#ifdef HAVE_TIMES
-static
-long mytime()
-{
- struct tms time_buffer;
- times(&time_buffer);
- return time_buffer.tms_utime + time_buffer.tms_stime;
-}
-#else
-# ifdef LACK_CLOCK
-# define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK)
-# else
-# define mytime clock
-# endif
-#endif
-
-
-
-#ifdef HAVE_FTIME
-
-extern int ftime (struct timeb *);
-
-struct timeb scm_your_base = {0};
-SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
-SCM
-scm_get_internal_real_time()
-{
- struct timeb time_buffer;
- long tmp;
- ftime(&time_buffer);
- time_buffer.time -= scm_your_base.time;
- tmp = time_buffer.millitm - scm_your_base.millitm;
- tmp = time_buffer.time*1000L + tmp;
- tmp *= CLKTCK;
- tmp /= 1000;
- return SCM_MAKINUM(tmp);
-}
-
-#else
-
-timet scm_your_base = 0;
-SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
-SCM
-scm_get_internal_real_time()
-{
- return SCM_MAKINUM((time((timet*)0) - scm_your_base) * (int)CLKTCK);
-}
-#endif
-
-
-
-static long scm_my_base = 0;
-
-SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time);
-SCM
-scm_get_internal_run_time()
-{
- return SCM_MAKINUM(mytime()-scm_my_base);
-}
-
-SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time);
-SCM
-scm_current_time()
-{
- timet timv = time((timet*)0);
- SCM ans;
- ans = scm_ulong2num(timv);
- return SCM_BOOL_F==ans ? SCM_MAKINUM(timv) : ans;
-}
-
-long
-scm_time_in_msec(x)
- long x;
-{
- if (CLKTCK==60) return (x*50)/3;
- else
- return (CLKTCK < 1000 ? x*(1000L/(long)CLKTCK) : (x*1000L)/(long)CLKTCK);
-}
-
-void
-scm_init_stime()
-{
- scm_sysintern("internal-time-units-per-second",
- SCM_MAKINUM((long)CLKTCK));
-
-#ifdef HAVE_FTIME
- if (!scm_your_base.time) ftime(&scm_your_base);
-#else
- if (!scm_your_base) time(&scm_your_base);
-#endif
-
- if (!scm_my_base) scm_my_base = mytime();
-
-#include "stime.x"
-}
-
diff --git a/libguile/stime.h b/libguile/stime.h
deleted file mode 100644
index 54a093bc3..000000000
--- a/libguile/stime.h
+++ /dev/null
@@ -1,56 +0,0 @@
-/* classes: h_files */
-
-#ifndef TIMEH
-#define TIMEH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-extern SCM scm_get_internal_real_time SCM_P ((void));
-extern SCM scm_get_internal_run_time SCM_P ((void));
-extern SCM scm_current_time SCM_P ((void));
-extern long scm_time_in_msec SCM_P ((long x));
-extern void scm_init_stime SCM_P ((void));
-
-#endif /* TIMEH */
diff --git a/libguile/strerror.c b/libguile/strerror.c
deleted file mode 100644
index 4723d04e8..000000000
--- a/libguile/strerror.c
+++ /dev/null
@@ -1,32 +0,0 @@
-/* Turning errno values into English error messages.
- Copyright (C) 1985, 86, 87, 88, 93, 94, 95 Free Software Foundation, Inc.
-
-This file is part of GNU Emacs.
-
-GNU Emacs is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with GNU Emacs; see the file COPYING. If not, write to
-the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
-
-
-char *
-strerror (errnum)
- int errnum;
-{
- extern char *sys_errlist[];
- extern int sys_nerr;
-
- if (errnum >= 0 && errnum < sys_nerr)
- return sys_errlist[errnum];
- return (char *) "Unknown error";
-}
diff --git a/libguile/strings.c b/libguile/strings.c
deleted file mode 100644
index e3c24406b..000000000
--- a/libguile/strings.c
+++ /dev/null
@@ -1,407 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-
-#include "strings.h"
-
-
-/* {Strings}
- */
-
-SCM_PROC(s_string_p, "string?", 1, 0, 0, scm_string_p);
-
-SCM
-scm_string_p (x)
- SCM x;
-{
- if (SCM_IMP (x))
- return SCM_BOOL_F;
- return SCM_STRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_read_only_string_p, "read-only-string?", 1, 0, 0, scm_read_only_string_p);
-
-SCM
-scm_read_only_string_p (x)
- SCM x;
-{
- if (SCM_IMP (x))
- return SCM_BOOL_F;
- return SCM_ROSTRINGP (x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_list_to_string, "list->string", 1, 0, 0, scm_string);
-SCM_PROC(s_string, "string", 0, 0, 1, scm_string);
-
-SCM
-scm_string (chrs)
- SCM chrs;
-{
- SCM res;
- register unsigned char *data;
- long i;
- long len;
- SCM_DEFER_INTS;
- i = scm_ilength (chrs);
- if (i < 0)
- {
- SCM_ALLOW_INTS;
- SCM_ASSERT (0, chrs, SCM_ARG1, s_string);
- }
- len = 0;
- {
- SCM s;
-
- for (len = 0, s = chrs; s != SCM_EOL; s = SCM_CDR (s))
- if (SCM_ICHRP (SCM_CAR (s)))
- len += 1;
- else if (SCM_NIMP (SCM_CAR (s)) && SCM_ROSTRINGP (SCM_CAR (s)))
- len += SCM_ROLENGTH (SCM_CAR (s));
- else
- {
- SCM_ALLOW_INTS;
- SCM_ASSERT (0, s, SCM_ARG1, s_string);
- }
- }
- res = scm_makstr (len, 0);
- data = SCM_UCHARS (res);
- for (;SCM_NNULLP (chrs);chrs = SCM_CDR (chrs))
- {
- if (SCM_ICHRP (SCM_CAR (chrs)))
- *data++ = SCM_ICHR (SCM_CAR (chrs));
- else
- {
- int l;
- char * c;
- l = SCM_ROLENGTH (SCM_CAR (chrs));
- c = SCM_ROUCHARS (SCM_CAR (chrs));
- while (l)
- {
- --l;
- *data++ = *c++;
- }
- }
- }
- SCM_ALLOW_INTS;
- return res;
-}
-
-
-SCM
-scm_makstr (len, slots)
- long len;
- int slots;
-{
- SCM s;
- SCM * mem;
- SCM_NEWCELL (s);
- --slots;
- SCM_REDEFER_INTS;
- mem = (SCM *)scm_must_malloc (sizeof (SCM) * (slots + 1) + len + 1,
- s_string);
- if (slots >= 0)
- {
- int x;
- mem[slots] = (SCM)mem;
- for (x = 0; x < slots; ++x)
- mem[x] = SCM_BOOL_F;
- }
- SCM_SETCHARS (s, (char *) (mem + slots + 1));
- SCM_SETLENGTH (s, len, scm_tc7_string);
- SCM_REALLOW_INTS;
- SCM_CHARS (s)[len] = 0;
- return s;
-}
-
-/* converts C scm_array of strings to SCM scm_list of strings. */
-/* If argc < 0, a null terminated scm_array is assumed. */
-
-SCM
-scm_makfromstrs (argc, argv)
- int argc;
- char **argv;
-{
- int i = argc;
- SCM lst = SCM_EOL;
- if (0 > i)
- for (i = 0; argv[i]; i++);
- while (i--)
- lst = scm_cons (scm_makfromstr (argv[i], (scm_sizet) strlen (argv[i]), 0), lst);
- return lst;
-}
-
-
-
-SCM
-scm_take0str (it)
- char * it;
-{
- SCM answer;
- SCM_NEWCELL (answer);
- SCM_DEFER_INTS;
- SCM_SETLENGTH (answer, strlen (it), scm_tc7_string);
- SCM_SETCHARS (answer, it);
- SCM_ALLOW_INTS;
- return answer;
-}
-
-
-SCM
-scm_makfromstr (src, len, slots)
- const char *src;
- scm_sizet len;
- int slots;
-{
- SCM s;
- register char *dst;
- s = scm_makstr ((long) len, slots);
- dst = SCM_CHARS (s);
- while (len--)
- *dst++ = *src++;
- return s;
-}
-
-
-
-SCM
-scm_makfrom0str (src)
- const char *src;
-{
- if (!src) return SCM_BOOL_F;
- return scm_makfromstr (src, (scm_sizet) strlen (src), 0);
-}
-
-
-SCM
-scm_makfrom0str_opt (src)
- const char *src;
-{
- return scm_makfrom0str (src);
-}
-
-
-
-
-SCM_PROC(s_make_string, "make-string", 1, 1, 0, scm_make_string);
-
-SCM
-scm_make_string (k, chr)
- SCM k;
- SCM chr;
-{
- SCM res;
- register unsigned char *dst;
- register long i;
- SCM_ASSERT (SCM_INUMP (k) && (k >= 0), k, SCM_ARG1, s_make_string);
- i = SCM_INUM (k);
- res = scm_makstr (i, 0);
- dst = SCM_UCHARS (res);
- if SCM_ICHRP (chr)
- {
- char c = SCM_ICHR (chr);
- for (i--;i >= 0;i--)
- {
- dst[i] = c;
- }
- }
- return res;
-}
-
-SCM_PROC(s_string_length, "string-length", 1, 0, 0, scm_string_length);
-
-SCM
-scm_string_length (str)
- SCM str;
-{
- SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_length);
- return SCM_MAKINUM (SCM_ROLENGTH (str));
-}
-
-SCM_PROC(s_string_ref, "string-ref", 1, 1, 0, scm_string_ref);
-
-SCM
-scm_string_ref (str, k)
- SCM str;
- SCM k;
-{
- SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_ref);
- if (k == SCM_UNDEFINED)
- k = SCM_MAKINUM (0);
- SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_ref);
- SCM_ASSERT (SCM_INUM (k) < SCM_ROLENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_ref);
- return SCM_MAKICHR (SCM_ROUCHARS (str)[SCM_INUM (k)]);
-}
-
-SCM_PROC(s_string_set_x, "string-set!", 3, 0, 0, scm_string_set_x);
-
-SCM
-scm_string_set_x (str, k, chr)
- SCM str;
- SCM k;
- SCM chr;
-{
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_set_x);
- SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG2, s_string_set_x);
- SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG3, s_string_set_x);
- SCM_ASSERT (SCM_INUM (k) < SCM_LENGTH (str) && SCM_INUM (k) >= 0, k, SCM_OUTOFRANGE, s_string_set_x);
- SCM_UCHARS (str)[SCM_INUM (k)] = SCM_ICHR (chr);
- return SCM_UNSPECIFIED;
-}
-
-
-
-SCM_PROC(s_substring, "substring", 2, 1, 0, scm_substring);
-
-SCM
-scm_substring (str, start, end)
- SCM str;
- SCM start;
- SCM end;
-{
- long l;
- SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str),
- str, SCM_ARG1, s_substring);
- SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring);
- if (end == SCM_UNDEFINED)
- end = SCM_MAKINUM (SCM_ROLENGTH (str));
- SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring);
- SCM_ASSERT (SCM_INUM (start) <= SCM_ROLENGTH (str), start, SCM_OUTOFRANGE, s_substring);
- SCM_ASSERT (SCM_INUM (end) <= SCM_ROLENGTH (str), end, SCM_OUTOFRANGE, s_substring);
- l = SCM_INUM (end)-SCM_INUM (start);
- SCM_ASSERT (l >= 0, SCM_MAKINUM (l), SCM_OUTOFRANGE, s_substring);
- return scm_makfromstr (&SCM_ROCHARS (str)[SCM_INUM (start)], (scm_sizet)l, 0);
-}
-
-SCM_PROC(s_string_append, "string-append", 0, 0, 1, scm_string_append);
-
-SCM
-scm_string_append (args)
- SCM args;
-{
- SCM res;
- register long i = 0;
- register SCM l, s;
- register unsigned char *data;
- for (l = args;SCM_NIMP (l);) {
- SCM_ASSERT (SCM_CONSP (l), l, SCM_ARGn, s_string_append);
- s = SCM_CAR (l);
- SCM_ASSERT (SCM_NIMP (s) && SCM_ROSTRINGP (s),
- s, SCM_ARGn, s_string_append);
- i += SCM_ROLENGTH (s);
- l = SCM_CDR (l);
- }
- SCM_ASSERT (SCM_NULLP (l), args, SCM_ARGn, s_string_append);
- res = scm_makstr (i, 0);
- data = SCM_UCHARS (res);
- for (l = args;SCM_NIMP (l);l = SCM_CDR (l)) {
- s = SCM_CAR (l);
- for (i = 0;i<SCM_ROLENGTH (s);i++) *data++ = SCM_ROUCHARS (s)[i];
- }
- return res;
-}
-
-SCM_PROC(s_make_shared_substring, "make-shared-substring", 1, 2, 0, scm_make_shared_substring);
-
-SCM
-scm_make_shared_substring (str, frm, to)
- SCM str;
- SCM frm;
- SCM to;
-{
- long f;
- long t;
- SCM answer;
- SCM len_str;
-
- SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_make_shared_substring);
-
- if (frm == SCM_UNDEFINED)
- frm = SCM_MAKINUM (0);
- else
- SCM_ASSERT (SCM_INUMP (frm), frm, SCM_ARG2, s_make_shared_substring);
-
- if (to == SCM_UNDEFINED)
- to = SCM_MAKINUM (SCM_ROLENGTH (str));
- else
- SCM_ASSERT (SCM_INUMP (to), to, SCM_ARG3, s_make_shared_substring);
-
- f = SCM_INUM (frm);
- t = SCM_INUM (to);
- SCM_ASSERT ((f >= 0), frm, SCM_OUTOFRANGE, s_make_shared_substring);
- SCM_ASSERT ((f <= t) && (t <= SCM_ROLENGTH (str)), to, SCM_OUTOFRANGE, s_make_shared_substring);
-
- SCM_NEWCELL (answer);
- SCM_NEWCELL (len_str);
-
- SCM_DEFER_INTS;
- if (SCM_SUBSTRP (str))
- {
- long offset;
- offset = SCM_INUM (SCM_SUBSTR_OFFSET (str));
- f += offset;
- t += offset;
- SCM_SETCAR (len_str, SCM_MAKINUM (f));
- SCM_SETCDR (len_str, SCM_SUBSTR_STR (str));
- SCM_SETCDR (answer, len_str);
- SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
- }
- else
- {
- SCM_SETCAR (len_str, SCM_MAKINUM (f));
- SCM_SETCDR (len_str, str);
- SCM_SETCDR (answer, len_str);
- SCM_SETLENGTH (answer, t - f, scm_tc7_substring);
- }
- SCM_ALLOW_INTS;
- return answer;
-}
-
-
-void
-scm_init_strings ()
-{
-#include "strings.x"
-}
-
diff --git a/libguile/strings.h b/libguile/strings.h
deleted file mode 100644
index 93f5a6e43..000000000
--- a/libguile/strings.h
+++ /dev/null
@@ -1,79 +0,0 @@
-/* classes: h_files */
-
-#ifndef STRINGSH
-#define STRINGSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-
-
-#define SCM_STRINGP(x) (SCM_TYP7S(x)==scm_tc7_string)
-#define SCM_NSTRINGP(x) (!SCM_STRINGP(x))
-
-
-
-
-extern SCM scm_string_p SCM_P ((SCM x));
-extern SCM scm_read_only_string_p SCM_P ((SCM x));
-extern SCM scm_string SCM_P ((SCM chrs));
-extern SCM scm_makstr SCM_P ((long len, int slots));
-extern SCM scm_makfromstrs SCM_P ((int argc, char **argv));
-extern SCM scm_take0str SCM_P ((char * it));
-extern SCM scm_makfromstr SCM_P ((const char *src, scm_sizet len, int slots));
-extern SCM scm_makfrom0str SCM_P ((const char *src));
-extern SCM scm_makfrom0str_opt SCM_P ((const char *src));
-extern SCM scm_make_string SCM_P ((SCM k, SCM chr));
-extern SCM scm_string_length SCM_P ((SCM str));
-extern SCM scm_string_ref SCM_P ((SCM str, SCM k));
-extern SCM scm_string_set_x SCM_P ((SCM str, SCM k, SCM chr));
-extern SCM scm_substring SCM_P ((SCM str, SCM start, SCM end));
-extern SCM scm_string_append SCM_P ((SCM args));
-extern SCM scm_make_shared_substring SCM_P ((SCM str, SCM frm, SCM to));
-extern void scm_init_strings SCM_P ((void));
-
-#endif /* STRINGSH */
diff --git a/libguile/strop.c b/libguile/strop.c
deleted file mode 100644
index 2f73f9724..000000000
--- a/libguile/strop.c
+++ /dev/null
@@ -1,325 +0,0 @@
-/* classes: src_files */
-
-/* Copyright (C) 1994 Free Software Foundation, Inc.
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this software; see the file COPYING. If not, write to
-the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-
-#include "strop.h"
-
-
-
-int
-scm_i_index (str, chr, sub_start, sub_end, pos, pos2, pos3, pos4, why)
- SCM * str;
- SCM chr;
- SCM sub_start;
- SCM sub_end;
- int pos;
- int pos2;
- int pos3;
- int pos4;
- char * why;
-{
- unsigned char * p;
- int x;
- int bound;
- int ch;
-
- SCM_ASSERT (SCM_NIMP (*str) && SCM_ROSTRINGP (*str), *str, pos, why);
- SCM_ASSERT (SCM_ICHRP (chr), chr, pos2, why);
-
- if (sub_start == SCM_BOOL_F)
- sub_start = SCM_MAKINUM (0);
- else
- SCM_ASSERT ( SCM_INUMP (sub_start)
- && (0 <= SCM_INUM (sub_start))
- && (SCM_INUM (sub_start) <= SCM_ROLENGTH (*str)),
- sub_start, pos3, why);
-
- if (sub_end == SCM_BOOL_F)
- sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str));
- else
- SCM_ASSERT ( SCM_INUMP (sub_end)
- && (SCM_INUM (sub_start) <= SCM_INUM (sub_end))
- && (SCM_INUM (sub_end) <= SCM_ROLENGTH (*str)),
- sub_end, pos4, why);
-
- p = (unsigned char *)SCM_ROCHARS (*str) + SCM_INUM (sub_start);
- bound = SCM_INUM (sub_end);
- ch = SCM_ICHR (chr);
-
- for (x = SCM_INUM (sub_start); x < bound; ++x, ++p)
- if (*p == ch)
- return x;
-
- return -1;
-}
-
-
-int
-scm_i_rindex (str, chr, sub_start, sub_end, pos, pos2, pos3, pos4, why)
- SCM * str;
- SCM chr;
- SCM sub_start;
- SCM sub_end;
- int pos;
- int pos2;
- int pos3;
- int pos4;
- char * why;
-{
- unsigned char * p;
- int x;
- int upper_bound;
- int lower_bound;
- int ch;
-
- SCM_ASSERT (SCM_NIMP (*str) && SCM_ROSTRINGP (*str), *str, pos, why);
- SCM_ASSERT (SCM_ICHRP (chr), chr, pos2, why);
-
- if (sub_start == SCM_BOOL_F)
- sub_start = SCM_MAKINUM (0);
- else
- SCM_ASSERT ( SCM_INUMP (sub_start)
- && (0 <= SCM_INUM (sub_start))
- && (SCM_INUM (sub_start) <= SCM_ROLENGTH (*str)),
- sub_start, pos3, why);
-
- if (sub_end == SCM_BOOL_F)
- sub_end = SCM_MAKINUM (SCM_ROLENGTH (*str));
- else
- SCM_ASSERT ( SCM_INUMP (sub_end)
- && (SCM_INUM (sub_start) <= SCM_INUM (sub_end))
- && (SCM_INUM (sub_end) <= SCM_ROLENGTH (*str)),
- sub_end, pos4, why);
-
- upper_bound = SCM_INUM (sub_end);
- lower_bound = SCM_INUM (sub_start);
- p = upper_bound - 1 + (unsigned char *)SCM_ROCHARS (*str);
- ch = SCM_ICHR (chr);
- for (x = upper_bound - 1; x >= lower_bound; --x, --p)
- if (*p == ch)
- return x;
-
- return -1;
-}
-
-
-SCM_PROC(s_string_index, "string-index", 2, 2, 0, scm_string_index);
-
-SCM
-scm_string_index (str, chr, frm, to)
- SCM str;
- SCM chr;
- SCM frm;
- SCM to;
-{
- int pos;
-
- if (frm == SCM_UNDEFINED)
- frm = SCM_BOOL_F;
- if (to == SCM_UNDEFINED)
- to = SCM_BOOL_F;
- pos = scm_i_index (&str, chr, frm, to, SCM_ARG1, SCM_ARG2, SCM_ARG3, SCM_ARG4, s_string_index);
- return (pos < 0
- ? SCM_BOOL_F
- : SCM_MAKINUM (pos));
-}
-
-SCM_PROC(s_string_rindex, "string-rindex", 2, 2, 0, scm_string_rindex);
-
-SCM
-scm_string_rindex (str, chr, frm, to)
- SCM str;
- SCM chr;
- SCM frm;
- SCM to;
-{
- int pos;
-
- if (frm == SCM_UNDEFINED)
- frm = SCM_BOOL_F;
- if (to == SCM_UNDEFINED)
- to = SCM_BOOL_F;
- pos = scm_i_rindex (&str, chr, frm, to, SCM_ARG1, SCM_ARG2, SCM_ARG3, SCM_ARG4, s_string_index);
- return (pos < 0
- ? SCM_BOOL_F
- : SCM_MAKINUM (pos));
-}
-
-
-
-
-
-
-SCM_PROC(s_substring_move_left_x, "substring-move-left!", 2, 0, 1, scm_substring_move_left_x);
-
-SCM
-scm_substring_move_left_x (str1, start1, args)
- SCM str1;
- SCM start1;
- SCM args;
-{
- SCM end1, str2, start2;
- long i, j, e;
- SCM_ASSERT (3==scm_ilength (args), scm_makfrom0str (s_substring_move_left_x),
- SCM_WNA, NULL);
- end1 = SCM_CAR (args); args = SCM_CDR (args);
- str2 = SCM_CAR (args); args = SCM_CDR (args);
- start2 = SCM_CAR (args);
- SCM_ASSERT (SCM_NIMP (str1) && SCM_STRINGP (str1), str1, SCM_ARG1, s_substring_move_left_x);
- SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_substring_move_left_x);
- SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_substring_move_left_x);
- SCM_ASSERT (SCM_NIMP (str2) && SCM_STRINGP (str2), str2, SCM_ARG4, s_substring_move_left_x);
- SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_substring_move_left_x);
- i = SCM_INUM (start1), j = SCM_INUM (start2), e = SCM_INUM (end1);
- SCM_ASSERT (i <= SCM_LENGTH (str1) && i >= 0, start1, SCM_OUTOFRANGE, s_substring_move_left_x);
- SCM_ASSERT (j <= SCM_LENGTH (str2) && j >= 0, start2, SCM_OUTOFRANGE, s_substring_move_left_x);
- SCM_ASSERT (e <= SCM_LENGTH (str1) && e >= 0, end1, SCM_OUTOFRANGE, s_substring_move_left_x);
- SCM_ASSERT (e-i+j <= SCM_LENGTH (str2), start2, SCM_OUTOFRANGE, s_substring_move_left_x);
- while (i<e) SCM_CHARS (str2)[j++] = SCM_CHARS (str1)[i++];
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_substring_move_right_x, "substring-move-right!", 2, 0, 1, scm_substring_move_right_x);
-
-SCM
-scm_substring_move_right_x (str1, start1, args)
- SCM str1;
- SCM start1;
- SCM args;
-{
- SCM end1, str2, start2;
- long i, j, e;
- SCM_ASSERT (3==scm_ilength (args),
- scm_makfrom0str (s_substring_move_right_x), SCM_WNA, NULL);
- end1 = SCM_CAR (args); args = SCM_CDR (args);
- str2 = SCM_CAR (args); args = SCM_CDR (args);
- start2 = SCM_CAR (args);
- SCM_ASSERT (SCM_NIMP (str1) && SCM_STRINGP (str1), str1, SCM_ARG1, s_substring_move_right_x);
- SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_substring_move_right_x);
- SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_substring_move_right_x);
- SCM_ASSERT (SCM_NIMP (str2) && SCM_STRINGP (str2), str2, SCM_ARG4, s_substring_move_right_x);
- SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_substring_move_right_x);
- i = SCM_INUM (start1), j = SCM_INUM (start2), e = SCM_INUM (end1);
- SCM_ASSERT (i <= SCM_LENGTH (str1) && i >= 0, start1, SCM_OUTOFRANGE, s_substring_move_right_x);
- SCM_ASSERT (j <= SCM_LENGTH (str2) && j >= 0, start2, SCM_OUTOFRANGE, s_substring_move_right_x);
- SCM_ASSERT (e <= SCM_LENGTH (str1) && e >= 0, end1, SCM_OUTOFRANGE, s_substring_move_right_x);
- SCM_ASSERT ((j = e-i+j) <= SCM_LENGTH (str2), start2, SCM_OUTOFRANGE, s_substring_move_right_x);
- while (i<e) SCM_CHARS (str2)[--j] = SCM_CHARS (str1)[--e];
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_substring_fill_x, "substring-fill!", 2, 0, 1, scm_substring_fill_x);
-
-SCM
-scm_substring_fill_x (str, start, args)
- SCM str;
- SCM start;
- SCM args;
-{
- SCM end, fill;
- long i, e;
- char c;
- SCM_ASSERT (2==scm_ilength (args), scm_makfrom0str (s_substring_fill_x),
- SCM_WNA, NULL);
- end = SCM_CAR (args); args = SCM_CDR (args);
- fill = SCM_CAR (args);
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_substring_fill_x);
- SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_substring_fill_x);
- SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_substring_fill_x);
- SCM_ASSERT (SCM_ICHRP (fill), fill, SCM_ARG4, s_substring_fill_x);
- i = SCM_INUM (start), e = SCM_INUM (end);c = SCM_ICHR (fill);
- SCM_ASSERT (i <= SCM_LENGTH (str) && i >= 0, start, SCM_OUTOFRANGE, s_substring_fill_x);
- SCM_ASSERT (e <= SCM_LENGTH (str) && e >= 0, end, SCM_OUTOFRANGE, s_substring_fill_x);
- while (i<e) SCM_CHARS (str)[i++] = c;
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_string_null_p, "string-null?", 1, 0, 0, scm_string_null_p);
-
-SCM
-scm_string_null_p (str)
- SCM str;
-{
- SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_null_p);
- return (SCM_ROLENGTH (str)
- ? SCM_BOOL_F
- : SCM_BOOL_T);
-}
-
-
-SCM_PROC(s_string_to_list, "string->list", 1, 0, 0, scm_string_to_list);
-
-SCM
-scm_string_to_list (str)
- SCM str;
-{
- long i;
- SCM res = SCM_EOL;
- unsigned char *src;
- SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_string_to_list);
- src = SCM_ROUCHARS (str);
- for (i = SCM_ROLENGTH (str)-1;i >= 0;i--) res = scm_cons ((SCM)SCM_MAKICHR (src[i]), res);
- return res;
-}
-
-
-
-SCM_PROC(s_string_copy, "string-copy", 1, 0, 0, scm_string_copy);
-
-SCM
-scm_string_copy (str)
- SCM str;
-{
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_copy);
- return scm_makfromstr (SCM_CHARS (str), (scm_sizet)SCM_LENGTH (str), 0);
-}
-
-
-SCM_PROC(s_string_fill_x, "string-fill!", 2, 0, 0, scm_string_fill_x);
-
-SCM
-scm_string_fill_x (str, chr)
- SCM str;
- SCM chr;
-{
- register char *dst, c;
- register long k;
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG1, s_string_fill_x);
- SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG2, s_string_fill_x);
- c = SCM_ICHR (chr);
- dst = SCM_CHARS (str);
- for (k = SCM_LENGTH (str)-1;k >= 0;k--) dst[k] = c;
- return SCM_UNSPECIFIED;
-}
-
-
-
-void
-scm_init_strop ()
-{
-#include "strop.x"
-}
-
diff --git a/libguile/strop.h b/libguile/strop.h
deleted file mode 100644
index fea23d79c..000000000
--- a/libguile/strop.h
+++ /dev/null
@@ -1,65 +0,0 @@
-/* classes: h_files */
-
-#ifndef STROPH
-#define STROPH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-
-extern int scm_i_index SCM_P ((SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why));
-extern int scm_i_rindex SCM_P ((SCM * str, SCM chr, SCM sub_start, SCM sub_end, int pos, int pos2, int pos3, int pos4, char * why));
-extern SCM scm_string_index SCM_P ((SCM str, SCM chr, SCM frm, SCM to));
-extern SCM scm_string_rindex SCM_P ((SCM str, SCM chr, SCM frm, SCM to));
-extern SCM scm_substring_move_left_x SCM_P ((SCM str1, SCM start1, SCM args));
-extern SCM scm_substring_move_right_x SCM_P ((SCM str1, SCM start1, SCM args));
-extern SCM scm_substring_fill_x SCM_P ((SCM str, SCM start, SCM args));
-extern SCM scm_string_null_p SCM_P ((SCM str));
-extern SCM scm_string_to_list SCM_P ((SCM str));
-extern SCM scm_string_copy SCM_P ((SCM str));
-extern SCM scm_string_fill_x SCM_P ((SCM str, SCM chr));
-extern void scm_init_strop SCM_P ((void));
-
-#endif /* STROPH */
diff --git a/libguile/strorder.c b/libguile/strorder.c
deleted file mode 100644
index a4fe03daa..000000000
--- a/libguile/strorder.c
+++ /dev/null
@@ -1,224 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-
-#include "strorder.h"
-
-
-SCM_PROC1 (s_string_equal_p, "string=?", scm_tc7_rpsubr, scm_string_equal_p);
-
-SCM
-scm_string_equal_p (s1, s2)
- SCM s1;
- SCM s2;
-{
- register scm_sizet i;
- register unsigned char *c1, *c2;
- SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_equal_p);
- SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_equal_p);
-
- i = SCM_ROLENGTH (s2);
- if (SCM_ROLENGTH (s1) != i)
- {
- return SCM_BOOL_F;
- }
- c1 = SCM_ROUCHARS (s1);
- c2 = SCM_ROUCHARS (s2);
- while (0 != i--)
- if (*c1++ != *c2++)
- return SCM_BOOL_F;
- return SCM_BOOL_T;
-}
-
-SCM_PROC1 (s_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr, scm_string_ci_equal_p);
-
-SCM
-scm_string_ci_equal_p (s1, s2)
- SCM s1;
- SCM s2;
-{
- register scm_sizet i;
- register unsigned char *c1, *c2;
- SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_ci_equal_p);
- SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_ci_equal_p);
- i = SCM_ROLENGTH (s2);
- if (SCM_ROLENGTH (s1) != i)
- {
- return SCM_BOOL_F;
- }
- c1 = SCM_ROUCHARS (s1);
- c2 = SCM_ROUCHARS (s2);
- while (0 != i--)
- if (scm_upcase(*c1++) != scm_upcase(*c2++))
- return SCM_BOOL_F;
- return SCM_BOOL_T;
-}
-
-SCM_PROC1 (s_string_less_p, "string<?", scm_tc7_rpsubr, scm_string_less_p);
-
-SCM
-scm_string_less_p (s1, s2)
- SCM s1;
- SCM s2;
-{
- register scm_sizet i, len, s2len;
- register unsigned char *c1, *c2;
- register int c;
-
- SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_less_p);
- SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_less_p);
- len = SCM_ROLENGTH (s1);
- s2len = i = SCM_ROLENGTH (s2);
- if (len>i) i = len;
- c1 = SCM_ROUCHARS (s1);
- c2 = SCM_ROUCHARS (s2);
-
- for (i = 0;i<len;i++) {
- c = (*c1++ - *c2++);
- if (c>0)
- return SCM_BOOL_F;
- if (c<0)
- return SCM_BOOL_T;
- }
- {
- SCM answer;
- answer = (s2len != len) ? SCM_BOOL_T : SCM_BOOL_F;
- return answer;
- }
-}
-
-SCM_PROC1 (s_string_leq_p, "string<=?", scm_tc7_rpsubr, scm_string_leq_p);
-
-SCM
-scm_string_leq_p (s1, s2)
- SCM s1;
- SCM s2;
-{
- return SCM_BOOL_NOT (scm_string_less_p (s2, s1));
-}
-
-SCM_PROC1 (s_string_gr_p, "string>?", scm_tc7_rpsubr, scm_string_gr_p);
-
-SCM
-scm_string_gr_p (s1, s2)
- SCM s1;
- SCM s2;
-{
- return scm_string_less_p (s2, s1);
-}
-
-SCM_PROC1 (s_string_geq_p, "string>=?", scm_tc7_rpsubr, scm_string_geq_p);
-
-SCM
-scm_string_geq_p (s1, s2)
- SCM s1;
- SCM s2;
-{
- return SCM_BOOL_NOT (scm_string_less_p (s1, s2));
-}
-
-SCM_PROC1 (s_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr, scm_string_ci_less_p);
-
-SCM
-scm_string_ci_less_p (s1, s2)
- SCM s1;
- SCM s2;
-{
- register scm_sizet i, len, s2len;
- register unsigned char *c1, *c2;
- register int c;
- SCM_ASSERT (SCM_NIMP (s1) && SCM_ROSTRINGP (s1), s1, SCM_ARG1, s_string_ci_less_p);
- SCM_ASSERT (SCM_NIMP (s2) && SCM_ROSTRINGP (s2), s2, SCM_ARG2, s_string_ci_less_p);
- len = SCM_ROLENGTH (s1);
- s2len = i = SCM_ROLENGTH (s2);
- if (len>i) i=len;
- c1 = SCM_ROUCHARS (s1);
- c2 = SCM_ROUCHARS (s2);
- for (i = 0;i<len;i++) {
- c = (scm_upcase(*c1++) - scm_upcase(*c2++));
- if (c>0) return SCM_BOOL_F;
- if (c<0) return SCM_BOOL_T;
- }
- return (s2len != len) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC1 (s_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr, scm_string_ci_leq_p);
-
-SCM
-scm_string_ci_leq_p (s1, s2)
- SCM s1;
- SCM s2;
-{
- return SCM_BOOL_NOT (scm_string_ci_less_p (s2, s1));
-}
-
-SCM_PROC1 (s_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr, scm_string_ci_gr_p);
-
-SCM
-scm_string_ci_gr_p (s1, s2)
- SCM s1;
- SCM s2;
-{
- return scm_string_ci_less_p (s2, s1);
-}
-
-SCM_PROC1 (s_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr, scm_string_ci_geq_p);
-
-SCM
-scm_string_ci_geq_p (s1, s2)
- SCM s1;
- SCM s2;
-{
- return SCM_BOOL_NOT (scm_string_ci_less_p (s1, s2));
-}
-
-
-
-void
-scm_init_strorder ()
-{
-#include "strorder.x"
-}
-
diff --git a/libguile/strorder.h b/libguile/strorder.h
deleted file mode 100644
index 2263a1c7f..000000000
--- a/libguile/strorder.h
+++ /dev/null
@@ -1,68 +0,0 @@
-/* classes: h_files */
-
-#ifndef STRORDERH
-#define STRORDERH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-
-
-
-
-
-extern SCM scm_string_equal_p SCM_P ((SCM s1, SCM s2));
-extern SCM scm_string_ci_equal_p SCM_P ((SCM s1, SCM s2));
-extern SCM scm_string_less_p SCM_P ((SCM s1, SCM s2));
-extern SCM scm_string_leq_p SCM_P ((SCM s1, SCM s2));
-extern SCM scm_string_gr_p SCM_P ((SCM s1, SCM s2));
-extern SCM scm_string_geq_p SCM_P ((SCM s1, SCM s2));
-extern SCM scm_string_ci_less_p SCM_P ((SCM s1, SCM s2));
-extern SCM scm_string_ci_leq_p SCM_P ((SCM s1, SCM s2));
-extern SCM scm_string_ci_gr_p SCM_P ((SCM s1, SCM s2));
-extern SCM scm_string_ci_geq_p SCM_P ((SCM s1, SCM s2));
-extern void scm_init_strorder SCM_P ((void));
-
-#endif /* STRORDERH */
diff --git a/libguile/strports.c b/libguile/strports.c
deleted file mode 100644
index 3518c9cff..000000000
--- a/libguile/strports.c
+++ /dev/null
@@ -1,304 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "unif.h"
-#include "eval.h"
-#include "read.h"
-
-#include "strports.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-
-
-/* {Ports - string ports}
- *
- */
-
-
-static int prinstpt SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-
-static int
-prinstpt (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_prinport (exp, port, "string");
- return !0;
-}
-
-
-static int stputc SCM_P ((int c, SCM p));
-
-static int
-stputc (c, p)
- int c;
- SCM p;
-{
- scm_sizet ind = SCM_INUM (SCM_CAR (p));
- SCM_DEFER_INTS;
- if (ind >= SCM_LENGTH (SCM_CDR (p)))
- scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + (ind >> 1)));
- SCM_ALLOW_INTS;
- SCM_CHARS (SCM_CDR (p))[ind] = c;
- SCM_SETCAR (p, SCM_MAKINUM (ind + 1));
- return c;
-}
-
-
-static scm_sizet stwrite SCM_P ((char *str, scm_sizet siz, scm_sizet num, SCM p));
-
-static scm_sizet
-stwrite (str, siz, num, p)
- char *str;
- scm_sizet siz;
- scm_sizet num;
- SCM p;
-{
- scm_sizet ind = SCM_INUM (SCM_CAR (p));
- scm_sizet len = siz * num;
- char *dst;
- SCM_DEFER_INTS;
- if (ind + len >= SCM_LENGTH (SCM_CDR (p)))
- scm_vector_set_length_x (SCM_CDR (p), SCM_MAKINUM (ind + len + ((ind + len) >> 1)));
- SCM_ALLOW_INTS;
- dst = &(SCM_CHARS (SCM_CDR (p))[ind]);
- while (len--)
- dst[len] = str[len];
- SCM_SETCAR (p, SCM_MAKINUM (ind + siz * num));
- return num;
-}
-
-
-static int stputs SCM_P ((char *s, SCM p));
-
-static int
-stputs (s, p)
- char *s;
- SCM p;
-{
- stwrite (s, 1, strlen (s), p);
- return 0;
-}
-
-
-static int stgetc SCM_P ((SCM p));
-
-static int
-stgetc (p)
- SCM p;
-{
- scm_sizet ind = SCM_INUM (SCM_CAR (p));
- if (ind >= SCM_ROLENGTH (SCM_CDR (p)))
- return EOF;
- SCM_SETCAR (p, SCM_MAKINUM (ind + 1));
- return SCM_ROUCHARS (SCM_CDR (p))[ind];
-}
-
-
-SCM
-scm_mkstrport (pos, str, modes, caller)
- SCM pos;
- SCM str;
- long modes;
- char * caller;
-{
- SCM z;
- SCM stream;
- struct scm_port_table * pt;
-
- SCM_ASSERT(SCM_INUMP(pos) && SCM_INUM(pos) >= 0, pos, SCM_ARG1, caller);
- SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, caller);
- stream = scm_cons(pos, str);
- SCM_NEWCELL (z);
- SCM_DEFER_INTS;
- pt = scm_add_to_port_table (z);
- SCM_SETCAR (z, scm_tc16_strport | modes);
- SCM_SETPTAB_ENTRY (z, pt);
- SCM_SETSTREAM (z, stream);
- SCM_ALLOW_INTS;
- return z;
-}
-
-SCM_PROC(s_call_with_output_string, "call-with-output-string", 1, 0, 0, scm_call_with_output_string);
-
-SCM
-scm_call_with_output_string (proc)
- SCM proc;
-{
- SCM p;
- p = scm_mkstrport(SCM_INUM0, scm_make_string(SCM_MAKINUM(30), SCM_UNDEFINED),
- SCM_OPN | SCM_WRTNG,
- s_call_with_output_string);
- scm_apply (proc, p, scm_listofnull);
- {
- SCM answer;
- SCM_DEFER_INTS;
- answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (p))),
- SCM_INUM (SCM_CAR (SCM_STREAM (p))),
- 0);
- SCM_ALLOW_INTS;
- return answer;
- }
-}
-
-
-
-/* Return a Scheme string obtained by printing a given object.
- */
-
-
-SCM
-scm_strprint_obj (obj)
- SCM obj;
-{
- SCM str;
- SCM port;
-
- str = scm_makstr (64, 0);
- port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "scm_strprint_obj");
- scm_prin1 (obj, port, 1);
- {
- SCM answer;
- SCM_DEFER_INTS;
- answer = scm_makfromstr (SCM_CHARS (SCM_CDR (SCM_STREAM (port))),
- SCM_INUM (SCM_CAR (SCM_STREAM (port))),
- 0);
- SCM_ALLOW_INTS;
- return answer;
- }
-}
-
-
-
-
-SCM_PROC(s_call_with_input_string, "call-with-input-string", 2, 0, 0, scm_call_with_input_string);
-
-SCM
-scm_call_with_input_string (str, proc)
- SCM str;
- SCM proc;
-{
- SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, s_call_with_input_string);
- return scm_apply (proc, p, scm_listofnull);
-}
-
-
-
-/* Given a null-terminated string EXPR containing a Scheme expression
- read it, and return it as an SCM value. */
-SCM
-scm_read_0str (expr)
- char *expr;
-{
- SCM port = scm_mkstrport (SCM_MAKINUM (0),
- scm_makfrom0str (expr),
- SCM_OPN | SCM_RDNG,
- "scm_eval_0str");
- SCM form;
-
- /* Read expressions from that port; ignore the values. */
- form = scm_read (port, SCM_BOOL_F, SCM_BOOL_F);
-
- scm_close_port (port);
- return form;
-}
-
-/* Given a null-terminated string EXPR containing Scheme program text,
- evaluate it, and return the result of the last expression evaluated. */
-SCM
-scm_eval_0str (expr)
- char *expr;
-{
- SCM port = scm_mkstrport (SCM_MAKINUM (0),
- scm_makfrom0str (expr),
- SCM_OPN | SCM_RDNG,
- "scm_eval_0str");
- SCM form;
- SCM ans = SCM_EOL;
-
- /* Read expressions from that port; ignore the values. */
- while ((form = scm_read (port, SCM_BOOL_F, SCM_BOOL_F)) != SCM_EOF_VAL)
- ans = scm_eval_x (form);
-
- scm_close_port (port);
- return ans;
-}
-
-
-static int noop0 SCM_P ((SCM stream));
-
-static int
-noop0 (stream)
- SCM stream;
-{
- return 0;
-}
-
-
-scm_ptobfuns scm_stptob =
-{
- scm_markstream,
- noop0,
- prinstpt,
- 0,
- stputc,
- stputs,
- stwrite,
- noop0,
- stgetc,
- 0
-};
-
-
-
-void
-scm_init_strports ()
-{
-#include "strports.x"
-}
-
diff --git a/libguile/strports.h b/libguile/strports.h
deleted file mode 100644
index fc0a1ed9f..000000000
--- a/libguile/strports.h
+++ /dev/null
@@ -1,61 +0,0 @@
-/* classes: h_files */
-
-#ifndef STRPORTSH
-#define STRPORTSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-extern scm_ptobfuns scm_stptob;
-
-
-
-extern SCM scm_mkstrport SCM_P ((SCM pos, SCM str, long modes, char * caller));
-extern SCM scm_call_with_output_string SCM_P ((SCM proc));
-extern SCM scm_strprint_obj SCM_P ((SCM obj));
-extern SCM scm_call_with_input_string SCM_P ((SCM str, SCM proc));
-extern SCM scm_read_0str SCM_P ((char *expr));
-extern SCM scm_eval_0str SCM_P ((char *expr));
-extern void scm_init_strports SCM_P ((void));
-
-#endif /* STRPORTSH */
diff --git a/libguile/struct.c b/libguile/struct.c
deleted file mode 100644
index 51f934e07..000000000
--- a/libguile/struct.c
+++ /dev/null
@@ -1,607 +0,0 @@
-/* Copyright (C) 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-
-#include "struct.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-
-
-static SCM required_vtable_fields = SCM_BOOL_F;
-static int struct_num = 0;
-
-
-SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
-
-SCM
-scm_make_struct_layout (fields)
- SCM fields;
-{
- SCM new_sym;
- SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
- fields, SCM_ARG1, s_struct_make_layout);
-
- {
- char * field_desc;
- int len;
- int x;
-
- len = SCM_ROLENGTH (fields);
- field_desc = SCM_ROCHARS (fields);
- SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout);
-
- for (x = 0; x < len; x += 2)
- {
- switch (field_desc[x])
- {
- case 'u':
- case 'p':
-#if 0
- case 'i':
- case 'd':
-#endif
- case 's':
- break;
- default:
- SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout);
- }
-
- switch (field_desc[x + 1])
- {
- case 'w':
- SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
- "self fields not writable", s_struct_make_layout);
-
- case 'r':
- case 'o':
- break;
- case 'R':
- case 'W':
- case 'O':
- SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
- "self fields not allowed in tail array",
- s_struct_make_layout);
- SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]),
- "tail array field must be last field in layout",
- s_struct_make_layout);
- break;
- default:
- SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
- }
-#if 0
- if (field_desc[x] == 'd')
- {
- SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout);
- x += 2;
- goto recheck_ref;
- }
-#endif
- }
- new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F));
- }
- return scm_return_first (new_sym, fields);
-}
-
-
-
-
-
-static void init_struct SCM_P ((SCM handle, int tail_elts, SCM inits));
-
-static void
-init_struct (handle, tail_elts, inits)
- SCM handle;
- int tail_elts;
- SCM inits;
-{
- SCM layout;
- SCM * data;
- unsigned char * fields_desc;
- unsigned char prot = 0;
- int n_fields;
- SCM * mem;
- int tailp = 0;
-
- layout = SCM_STRUCT_LAYOUT (handle);
- data = SCM_STRUCT_DATA (handle);
- fields_desc = (unsigned char *) SCM_CHARS (layout) - 2;
- n_fields = SCM_LENGTH (layout) / 2;
- mem = SCM_STRUCT_DATA (handle);
- while (n_fields)
- {
- if (!tailp)
- {
- fields_desc += 2;
- prot = fields_desc[1];
- if (SCM_LAYOUT_TAILP (prot))
- {
- tailp = 1;
- prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
- *mem++ = tail_elts;
- n_fields += tail_elts - 1;
- if (n_fields == 0)
- break;
- }
- }
-
- switch (*fields_desc)
- {
-#if 0
- case 'i':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *mem = 0;
- else
- {
- *mem = scm_num2long (SCM_CAR (inits), SCM_ARGn, "init_struct");
- inits = SCM_CDR (inits);
- }
- break;
-#endif
-
- case 'u':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *mem = 0;
- else
- {
- *mem = scm_num2ulong (SCM_CAR (inits), SCM_ARGn, "init_struct");
- inits = SCM_CDR (inits);
- }
- break;
-
- case 'p':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *mem = SCM_EOL;
- else
- {
- *mem = SCM_CAR (inits);
- inits = SCM_CDR (inits);
- }
-
- break;
-
-#if 0
- case 'd':
- if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
- *((double *)mem) = 0.0;
- else
- {
- *mem = scm_num2dbl (SCM_CAR (inits), "init_struct");
- inits = SCM_CDR (inits);
- }
- fields_desc += 2;
- break;
-#endif
-
- case 's':
- *mem = handle;
- break;
- }
-
- n_fields--;
- mem++;
- }
-}
-
-
-SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
-
-SCM
-scm_struct_p (x)
- SCM x;
-{
- return ((SCM_NIMP (x) && SCM_STRUCTP (x))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
-
-SCM
-scm_struct_vtable_p (x)
- SCM x;
-{
- SCM layout;
- SCM * mem;
-
- if (SCM_IMP (x))
- return SCM_BOOL_F;
-
- if (!SCM_STRUCTP (x))
- return SCM_BOOL_F;
-
- layout = SCM_STRUCT_LAYOUT (x);
-
- if (SCM_LENGTH (layout) < SCM_LENGTH (required_vtable_fields))
- return SCM_BOOL_F;
-
- if (strncmp (SCM_CHARS (layout), SCM_CHARS (required_vtable_fields),
- SCM_LENGTH (required_vtable_fields)))
- return SCM_BOOL_F;
-
- mem = SCM_STRUCT_DATA (x);
-
- if (mem[1] != 0)
- return SCM_BOOL_F;
-
- if (SCM_IMP (mem[0]))
- return SCM_BOOL_F;
-
- return (SCM_SYMBOLP (mem[0])
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-/* All struct data must be allocated at an address whose bottom three
- bits are zero. This is because the tag for a struct lives in the
- bottom three bits of the struct's car, and the upper bits point to
- the data of its vtable, which is a struct itself. Thus, if the
- address of that data doesn't end in three zeros, tagging it will
- destroy the pointer.
-
- This function allocates a block of memory, and returns a pointer at
- least scm_struct_n_extra_words words into the block. Furthermore,
- it guarantees that that pointer's least three significant bits are
- all zero.
-
- The argument n_words should be the number of words that should
- appear after the returned address. (That is, it shouldn't include
- scm_struct_n_extra_words.)
-
- This function initializes the following fields of the struct:
-
- scm_struct_i_ptr --- the actual stort of the block of memory; the
- address you should pass to 'free' to dispose of the block.
- This field allows us to both guarantee that the returned
- address is divisible by eight, and allow the GC to free the
- block.
-
- scm_struct_i_n_words --- the number of words allocated to the
- block, including the extra fields. This is used by the GC.
-
- scm_struct_i_tag --- a unique tag assigned to this struct,
- allocated according to struct_num.
-
- Ugh. */
-
-
-static SCM *alloc_struct SCM_P ((int n_words, char *who));
-
-static SCM *
-alloc_struct (n_words, who)
- int n_words;
- char *who;
-{
- int size = sizeof (SCM) * (n_words + scm_struct_n_extra_words) + 7;
- SCM *block = (SCM *) scm_must_malloc (size, who);
-
- /* Adjust the pointer to hide the extra words. */
- SCM *p = block + scm_struct_n_extra_words;
-
- /* Adjust it even further so it's aligned on an eight-byte boundary. */
- p = (SCM *) (((SCM) p + 7) & ~7);
-
- /* Initialize a few fields as described above. */
- p[scm_struct_i_ptr] = (SCM) block;
- p[scm_struct_i_n_words] = (SCM) (scm_struct_n_extra_words + n_words);
- p[scm_struct_i_tag] = struct_num++;
-
- return p;
-}
-
-
-SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
-
-SCM
-scm_make_struct (vtable, tail_array_size, init)
- SCM vtable;
- SCM tail_array_size;
- SCM init;
-{
- SCM layout;
- int basic_size;
- int tail_elts;
- SCM * data;
- SCM handle;
-
- SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
- vtable, SCM_ARG1, s_make_struct);
- SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
- s_make_struct);
-
- layout = SCM_STRUCT_DATA (vtable)[scm_struct_i_layout];
- basic_size = SCM_LENGTH (layout) / 2;
- tail_elts = SCM_INUM (tail_array_size);
- SCM_NEWCELL (handle);
- SCM_DEFER_INTS;
- data = alloc_struct (basic_size + tail_elts, "make-struct");
- SCM_SETCDR (handle, data);
- SCM_SETCAR (handle, ((SCM)SCM_STRUCT_DATA (vtable)) + scm_tc3_cons_gloc);
- init_struct (handle, tail_elts, init);
- SCM_ALLOW_INTS;
- return handle;
-}
-
-
-
-SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
-
-SCM
-scm_make_vtable_vtable (extra_fields, tail_array_size, init)
- SCM extra_fields;
- SCM tail_array_size;
- SCM init;
-{
- SCM fields;
- SCM layout;
- int basic_size;
- int tail_elts;
- SCM * data;
- SCM handle;
-
- SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
- extra_fields, SCM_ARG1, s_make_vtable_vtable);
- SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
- s_make_vtable_vtable);
-
- fields = scm_string_append (scm_listify (required_vtable_fields,
- extra_fields,
- SCM_UNDEFINED));
- layout = scm_make_struct_layout (fields);
- basic_size = SCM_LENGTH (layout) / 2;
- tail_elts = SCM_INUM (tail_array_size);
- SCM_NEWCELL (handle);
- SCM_DEFER_INTS;
- data = alloc_struct (basic_size + tail_elts, "make-vtable-vtable");
- SCM_SETCDR (handle, data);
- SCM_SETCAR (handle, ((SCM)data) + scm_tc3_cons_gloc);
- SCM_STRUCT_LAYOUT (handle) = layout;
- init_struct (handle, tail_elts, scm_cons (layout, init));
- SCM_ALLOW_INTS;
- return handle;
-}
-
-
-
-
-SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
-
-SCM
-scm_struct_ref (handle, pos)
- SCM handle;
- SCM pos;
-{
- SCM answer = SCM_UNDEFINED;
- SCM * data;
- SCM layout;
- int p;
- int n_fields;
- unsigned char * fields_desc;
- unsigned char field_type;
-
-
- SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
- SCM_ARG1, s_struct_ref);
- SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
-
- layout = SCM_STRUCT_LAYOUT (handle);
- data = SCM_STRUCT_DATA (handle);
- p = SCM_INUM (pos);
-
- fields_desc = (unsigned char *)SCM_CHARS (layout);
- n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
-
- SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
-
- if (p * 2 < SCM_LENGTH (layout))
- {
- unsigned char ref;
- field_type = fields_desc[p * 2];
- ref = fields_desc[p * 2 + 1];
- if ((ref != 'r') && (ref != 'w'))
- {
- if ((ref == 'R') || (ref == 'W'))
- field_type = 'u';
- else
- SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
- }
- }
- else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
- field_type = fields_desc[SCM_LENGTH (layout) - 2];
- else
- {
- SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
- abort ();
- }
-
- switch (field_type)
- {
- case 'u':
- answer = scm_ulong2num (data[p]);
- break;
-
-#if 0
- case 'i':
- answer = scm_long2num (data[p]);
- break;
-
- case 'd':
- answer = scm_makdbl (*((double *)&(data[p])), 0.0);
- break;
-#endif
-
- case 's':
- case 'p':
- answer = data[p];
- break;
-
-
- default:
- SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
- break;
- }
-
- return answer;
-}
-
-
-SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
-
-SCM
-scm_struct_set_x (handle, pos, val)
- SCM handle;
- SCM pos;
- SCM val;
-{
- SCM * data;
- SCM layout;
- int p;
- int n_fields;
- unsigned char * fields_desc;
- unsigned char field_type;
-
-
-
- SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
- SCM_ARG1, s_struct_ref);
- SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
-
- layout = SCM_STRUCT_LAYOUT (handle);
- data = SCM_STRUCT_DATA (handle);
- p = SCM_INUM (pos);
-
- fields_desc = (unsigned char *)SCM_CHARS (layout);
- n_fields = data[- scm_struct_n_extra_words] - scm_struct_n_extra_words;
-
- SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
-
- if (p * 2 < SCM_LENGTH (layout))
- {
- unsigned char set_x;
- field_type = fields_desc[p * 2];
- set_x = fields_desc [p * 2 + 1];
- if (set_x != 'w')
- SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
- }
- else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
- field_type = fields_desc[SCM_LENGTH (layout) - 2];
- else
- {
- SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
- abort ();
- }
-
- switch (field_type)
- {
- case 'u':
- data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
- break;
-
-#if 0
- case 'i':
- data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
- break;
-
- case 'd':
- *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
- break;
-#endif
-
- case 'p':
- data[p] = val;
- break;
-
- case 's':
- SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
- break;
-
- default:
- SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
- break;
- }
-
- return val;
-}
-
-
-SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
-
-SCM
-scm_struct_vtable (handle)
- SCM handle;
-{
- SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
- SCM_ARG1, s_struct_vtable);
- return SCM_STRUCT_VTABLE (handle);
-}
-
-
-SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
-
-SCM
-scm_struct_vtable_tag (handle)
- SCM handle;
-{
- SCM_ASSERT (SCM_NIMP (handle) && (SCM_BOOL_F != scm_struct_vtable_p (handle)),
- handle, SCM_ARG1, s_struct_vtable_tag);
- return scm_long2num (SCM_STRUCT_DATA (handle)[-1]);
-}
-
-
-
-
-
-void
-scm_init_struct ()
-{
- required_vtable_fields = SCM_CAR (scm_intern_obarray ("pruosr", sizeof ("pruosr") - 1, SCM_BOOL_F));
- scm_permanent_object (required_vtable_fields);
- scm_sysintern ("struct-vtable-offset", SCM_MAKINUM (scm_struct_i_vtable_offset));
-#include "struct.x"
-}
-
diff --git a/libguile/struct.h b/libguile/struct.h
deleted file mode 100644
index e076a8aee..000000000
--- a/libguile/struct.h
+++ /dev/null
@@ -1,86 +0,0 @@
-/* classes: h_files */
-
-#ifndef STRUCTH
-#define STRUCTH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-/* Number of words with negative index */
-#define scm_struct_n_extra_words 3
-
-/* These are how the initial words of a vtable are allocated. */
-#define scm_struct_i_ptr -3 /* start of block (see alloc_struct) */
-#define scm_struct_i_n_words -2 /* How many words allocated to this struct? */
-#define scm_struct_i_tag -1 /* A unique tag for this type.. */
-#define scm_struct_i_layout 0 /* A symbol describing the physical arrangement of this type. */
-#define scm_struct_i_vcell 1 /* An opaque word, managed by the garbage collector. */
-#define scm_struct_i_vtable 2 /* A pointer to the handle for this vtable. */
-#define scm_struct_i_vtable_offset 3 /* Where do user fields start? */
-
-
-#define SCM_STRUCTP(X) (SCM_TYP3(X) == scm_tc3_cons_gloc)
-#define SCM_STRUCT_DATA(X) ((SCM*)(SCM_CDR(X)))
-#define SCM_STRUCT_VTABLE_DATA(X) ((SCM *)(SCM_CAR(X) - 1))
-#define SCM_STRUCT_LAYOUT(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_layout])
-#define SCM_STRUCT_VTABLE(X) (SCM_STRUCT_VTABLE_DATA(X)[scm_struct_i_vtable])
-/* Efficiency is important in the following macro, since it's used in GC */
-#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
-
-
-
-
-extern SCM scm_make_struct_layout SCM_P ((SCM fields));
-extern SCM scm_struct_p SCM_P ((SCM x));
-extern SCM scm_struct_vtable_p SCM_P ((SCM x));
-extern SCM scm_make_struct SCM_P ((SCM vtable, SCM tail_array_size, SCM init));
-extern SCM scm_make_vtable_vtable SCM_P ((SCM extra_fields, SCM tail_array_size, SCM init));
-extern SCM scm_struct_ref SCM_P ((SCM handle, SCM pos));
-extern SCM scm_struct_set_x SCM_P ((SCM handle, SCM pos, SCM val));
-extern SCM scm_struct_vtable SCM_P ((SCM handle));
-extern SCM scm_struct_vtable_tag SCM_P ((SCM handle));
-extern void scm_init_struct SCM_P ((void));
-
-#endif /* STRUCTH */
diff --git a/libguile/symbols.c b/libguile/symbols.c
deleted file mode 100644
index ec3fb9f93..000000000
--- a/libguile/symbols.c
+++ /dev/null
@@ -1,727 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-#include "eval.h"
-#include "variable.h"
-#include "alist.h"
-#include "mbstrings.h"
-
-#include "symbols.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-
-
-
-/* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets.
- */
-#define NUM_HASH_BUCKETS 137
-
-
-
-
-/* {Symbols}
- */
-
-
-unsigned long
-scm_strhash (str, len, n)
- unsigned char *str;
- scm_sizet len;
- unsigned long n;
-{
- if (len > 5)
- {
- scm_sizet i = 5;
- unsigned long h = 264 % n;
- while (i--)
- h = ((h << 8) + ((unsigned) (scm_downcase (str[h % len])))) % n;
- return h;
- }
- else
- {
- scm_sizet i = len;
- unsigned long h = 0;
- while (i)
- h = ((h << 8) + ((unsigned) (scm_downcase (str[--i])))) % n;
- return h;
- }
-}
-
-int scm_symhash_dim = NUM_HASH_BUCKETS;
-
-
-/* scm_sym2vcell
- * looks up the symbol in the symhash table.
- */
-
-SCM
-scm_sym2vcell (sym, thunk, definep)
- SCM sym;
- SCM thunk;
- SCM definep;
-{
- if (SCM_NIMP(thunk))
- {
- SCM var = scm_apply (thunk, sym, scm_cons(definep, scm_listofnull));
-
- if (var == SCM_BOOL_F)
- return SCM_BOOL_F;
- else
- {
- if (SCM_IMP(var) || !SCM_VARIABLEP (var))
- scm_wta (sym, "strangely interned symbol? ", "");
- return SCM_VARVCELL (var);
- }
- }
- else
- {
- SCM lsym;
- SCM * lsymp;
- SCM z;
- scm_sizet scm_hash = scm_strhash (SCM_UCHARS (sym), (scm_sizet) SCM_LENGTH (sym),
- (unsigned long) scm_symhash_dim);
-
- SCM_DEFER_INTS;
- for (lsym = SCM_VELTS (scm_symhash)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
- {
- z = SCM_CAR (lsym);
- if (SCM_CAR (z) == sym)
- {
- SCM_ALLOW_INTS;
- return z;
- }
- }
-
- for (lsym = *(lsymp = &SCM_VELTS (scm_weak_symhash)[scm_hash]);
- SCM_NIMP (lsym);
- lsym = *(lsymp = SCM_CDRLOC (lsym)))
- {
- z = SCM_CAR (lsym);
- if (SCM_CAR (z) == sym)
- {
- if (definep)
- {
- /* Move handle from scm_weak_symhash to scm_symhash. */
- *lsymp = SCM_CDR (lsym);
- SCM_SETCDR (lsym, SCM_VELTS(scm_symhash)[scm_hash]);
- SCM_VELTS(scm_symhash)[scm_hash] = lsym;
- }
- SCM_ALLOW_INTS;
- return z;
- }
- }
- SCM_ALLOW_INTS;
- return scm_wta (sym, "uninterned symbol? ", "");
- }
-}
-
-/* scm_sym2ovcell
- * looks up the symbol in an arbitrary obarray.
- */
-
-SCM
-scm_sym2ovcell_soft (sym, obarray)
- SCM sym;
- SCM obarray;
-{
- SCM lsym, z;
- scm_sizet scm_hash;
-
- scm_hash = scm_strhash (SCM_UCHARS (sym),
- (scm_sizet) SCM_LENGTH (sym),
- SCM_LENGTH (obarray));
- SCM_REDEFER_INTS;
- for (lsym = SCM_VELTS (obarray)[scm_hash];
- SCM_NIMP (lsym);
- lsym = SCM_CDR (lsym))
- {
- z = SCM_CAR (lsym);
- if (SCM_CAR (z) == sym)
- {
- SCM_REALLOW_INTS;
- return z;
- }
- }
- SCM_REALLOW_INTS;
- return SCM_BOOL_F;
-}
-
-
-SCM
-scm_sym2ovcell (sym, obarray)
- SCM sym;
- SCM obarray;
-{
- SCM answer;
- answer = scm_sym2ovcell_soft (sym, obarray);
- if (answer != SCM_BOOL_F)
- return answer;
- scm_wta (sym, "uninterned symbol? ", "");
- return SCM_UNSPECIFIED; /* not reached */
-}
-
-/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
-
- OBARRAY should be a vector of lists, indexed by the name's hash
- value, modulo OBARRAY's length. Each list has the form
- ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
- value associated with that symbol (in the current module? in the
- system module?)
-
- To "intern" a symbol means: if OBARRAY already contains a symbol by
- that name, return its (SYMBOL . VALUE) pair; otherwise, create a
- new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
- appropriate list of the OBARRAY, and return the pair.
-
- If softness is non-zero, don't create a symbol if it isn't already
- in OBARRAY; instead, just return #f.
-
- If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
- return (SYMBOL . SCM_UNDEFINED).
-
- If OBARRAY is scm_symhash, and that doesn't contain the symbol,
- check scm_weak_symhash instead. */
-
-
-SCM
-scm_intern_obarray_soft (name, len, obarray, softness)
- char *name;
- scm_sizet len;
- SCM obarray;
- int softness;
-{
- SCM lsym;
- SCM z;
- register scm_sizet i;
- register unsigned char *tmp;
- scm_sizet scm_hash;
-
- SCM_REDEFER_INTS;
-
- i = len;
- tmp = (unsigned char *) name;
-
- if (obarray == SCM_BOOL_F)
- {
- scm_hash = scm_strhash (tmp, i, 1019);
- goto uninterned_symbol;
- }
-
- scm_hash = scm_strhash (tmp, i, SCM_LENGTH(obarray));
-
- /* softness == -1 used to mean that it was known that the symbol
- wasn't already in the obarray. I don't think there are any
- callers that use that case any more, but just in case...
- -- JimB, Oct 1996 */
- if (softness == -1)
- abort ();
-
- retry_new_obarray:
- for (lsym = SCM_VELTS (obarray)[scm_hash]; SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
- {
- z = SCM_CAR (lsym);
- z = SCM_CAR (z);
- tmp = SCM_UCHARS (z);
- if (SCM_LENGTH (z) != len)
- goto trynext;
- for (i = len; i--;)
- if (((unsigned char *) name)[i] != tmp[i])
- goto trynext;
- {
- SCM a;
- a = SCM_CAR (lsym);
- SCM_REALLOW_INTS;
- return a;
- }
- trynext:;
- }
-
- if (obarray == scm_symhash)
- {
- obarray = scm_weak_symhash;
- goto retry_new_obarray;
- }
-
- uninterned_symbol:
- if (softness)
- {
- SCM_REALLOW_INTS;
- return SCM_BOOL_F;
- }
-
- lsym = scm_makfromstr (name, len, SCM_SYMBOL_SLOTS);
-
- SCM_SETLENGTH (lsym, (long) len, scm_tc7_msymbol);
- SCM_SYMBOL_MULTI_BYTE_STRINGP (lsym) = SCM_BOOL_F;
- SCM_SYMBOL_HASH (lsym) = scm_hash;
- SCM_SYMBOL_PROPS (lsym) = SCM_EOL;
- if (obarray == SCM_BOOL_F)
- {
- SCM answer;
- SCM_REALLOW_INTS;
- SCM_NEWCELL (answer);
- SCM_DEFER_INTS;
- SCM_SETCAR (answer, lsym);
- SCM_SETCDR (answer, SCM_UNDEFINED);
- SCM_REALLOW_INTS;
- return answer;
- }
- else
- {
- SCM a;
- SCM b;
-
- SCM_NEWCELL (a);
- SCM_NEWCELL (b);
- SCM_SETCAR (a, lsym);
- SCM_SETCDR (a, SCM_UNDEFINED);
- SCM_SETCAR (b, a);
- SCM_SETCDR (b, SCM_VELTS(obarray)[scm_hash]);
- SCM_VELTS(obarray)[scm_hash] = b;
- SCM_REALLOW_INTS;
- return SCM_CAR (b);
- }
-}
-
-
-SCM
-scm_intern_obarray (name, len, obarray)
- char *name;
- scm_sizet len;
- SCM obarray;
-{
- return scm_intern_obarray_soft (name, len, obarray, 0);
-}
-
-
-SCM
-scm_intern (name, len)
- char *name;
- scm_sizet len;
-{
- return scm_intern_obarray (name, len, scm_symhash);
-}
-
-
-SCM
-scm_intern0 (name)
- char * name;
-{
- return scm_intern (name, strlen (name));
-}
-
-
-/* Intern the symbol named NAME in scm_symhash, and give it the value VAL.
- NAME is null-terminated. */
-SCM
-scm_sysintern (name, val)
- char *name;
- SCM val;
-{
- SCM easy_answer;
- SCM_DEFER_INTS;
- easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1);
- if (SCM_NIMP (easy_answer))
- {
- SCM_SETCDR (easy_answer, val);
- SCM_ALLOW_INTS;
- return easy_answer;
- }
- else
- {
- SCM lsym;
- scm_sizet len = strlen (name);
- register unsigned char *tmp = (unsigned char *) name;
- scm_sizet scm_hash = scm_strhash (tmp, len, (unsigned long) scm_symhash_dim);
- SCM_NEWCELL (lsym);
- SCM_SETLENGTH (lsym, (long) len, scm_tc7_ssymbol);
- SCM_SETCHARS (lsym, name);
- lsym = scm_cons (lsym, val);
- SCM_VELTS (scm_symhash)[scm_hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[scm_hash]);
- SCM_ALLOW_INTS;
- return lsym;
- }
-}
-
-
-SCM_PROC(s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p);
-
-SCM
-scm_symbol_p(x)
- SCM x;
-{
- if SCM_IMP(x) return SCM_BOOL_F;
- return SCM_SYMBOLP(x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_symbol_to_string, "symbol->string", 1, 0, 0, scm_symbol_to_string);
-
-SCM
-scm_symbol_to_string(s)
- SCM s;
-{
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_to_string);
- return scm_makfromstr(SCM_CHARS(s), (scm_sizet)SCM_LENGTH(s), 0);
-}
-
-
-SCM_PROC(s_string_to_symbol, "string->symbol", 1, 0, 0, scm_string_to_symbol);
-
-SCM
-scm_string_to_symbol(s)
- SCM s;
-{
- SCM vcell;
- SCM answer;
-
- SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG1, s_string_to_symbol);
- vcell = scm_intern(SCM_ROCHARS(s), (scm_sizet)SCM_LENGTH(s));
- answer = SCM_CAR (vcell);
- if (SCM_TYP7 (answer) == scm_tc7_msymbol)
- {
- if (SCM_REGULAR_STRINGP (s))
- SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
- else
- SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
- }
- return answer;
-}
-
-
-SCM_PROC(s_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, scm_string_to_obarray_symbol);
-
-SCM
-scm_string_to_obarray_symbol(o, s, softp)
- SCM o;
- SCM s;
- SCM softp;
-{
- SCM vcell;
- SCM answer;
- int softness;
-
- SCM_ASSERT(SCM_NIMP(s) && SCM_ROSTRINGP(s), s, SCM_ARG2,
- s_string_to_obarray_symbol);
- SCM_ASSERT((o == SCM_BOOL_F)
- || (o == SCM_BOOL_T)
- || (SCM_NIMP(o) && SCM_VECTORP(o)),
- o,
- SCM_ARG1,
- s_string_to_obarray_symbol);
-
- softness = ((softp != SCM_UNDEFINED) && (softp != SCM_BOOL_F));
- /* iron out some screwy calling conventions */
- if (o == SCM_BOOL_F)
- o = scm_symhash;
- else if (o == SCM_BOOL_T)
- o = SCM_BOOL_F;
-
- vcell = scm_intern_obarray_soft (SCM_ROCHARS(s),
- (scm_sizet)SCM_ROLENGTH(s),
- o,
- softness);
- if (vcell == SCM_BOOL_F)
- return vcell;
- answer = SCM_CAR (vcell);
- if (SCM_TYP7 (s) == scm_tc7_msymbol)
- {
- if (SCM_REGULAR_STRINGP (s))
- SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_F;
- else
- SCM_SYMBOL_MULTI_BYTE_STRINGP (answer) = SCM_BOOL_T;
- }
- return answer;
-}
-
-SCM_PROC(s_intern_symbol, "intern-symbol", 2, 0, 0, scm_intern_symbol);
-
-SCM
-scm_intern_symbol(o, s)
- SCM o;
- SCM s;
-{
- scm_sizet hval;
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_intern_symbol);
- if (o == SCM_BOOL_F)
- o = scm_symhash;
- SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_intern_symbol);
- hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
- /* If the symbol is already interned, simply return. */
- SCM_REDEFER_INTS;
- {
- SCM lsym;
- SCM sym;
- for (lsym = SCM_VELTS (o)[hval];
- SCM_NIMP (lsym);
- lsym = SCM_CDR (lsym))
- {
- sym = SCM_CAR (lsym);
- if (SCM_CAR (sym) == s)
- {
- SCM_REALLOW_INTS;
- return SCM_UNSPECIFIED;
- }
- }
- SCM_VELTS (o)[hval] =
- scm_acons (s, SCM_UNDEFINED, SCM_VELTS (o)[hval]);
- }
- SCM_REALLOW_INTS;
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC(s_unintern_symbol, "unintern-symbol", 2, 0, 0, scm_unintern_symbol);
-
-SCM
-scm_unintern_symbol(o, s)
- SCM o;
- SCM s;
-{
- scm_sizet hval;
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_unintern_symbol);
- if (o == SCM_BOOL_F)
- o = scm_symhash;
- SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_unintern_symbol);
- hval = scm_strhash (SCM_UCHARS (s), SCM_LENGTH (s), SCM_LENGTH(o));
- SCM_DEFER_INTS;
- {
- SCM lsym_follow;
- SCM lsym;
- SCM sym;
- for (lsym = SCM_VELTS (o)[hval], lsym_follow = SCM_BOOL_F;
- SCM_NIMP (lsym);
- lsym_follow = lsym, lsym = SCM_CDR (lsym))
- {
- sym = SCM_CAR (lsym);
- if (SCM_CAR (sym) == s)
- {
- /* Found the symbol to unintern. */
- if (lsym_follow == SCM_BOOL_F)
- SCM_VELTS(o)[hval] = lsym;
- else
- SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
- SCM_ALLOW_INTS;
- return SCM_BOOL_T;
- }
- }
- }
- SCM_ALLOW_INTS;
- return SCM_BOOL_F;
-}
-
-SCM_PROC(s_symbol_binding, "symbol-binding", 2, 0, 0, scm_symbol_binding);
-
-SCM
-scm_symbol_binding (o, s)
- SCM o;
- SCM s;
-{
- SCM vcell;
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_binding);
- if (o == SCM_BOOL_F)
- o = scm_symhash;
- SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_binding);
- vcell = scm_sym2ovcell (s, o);
- return SCM_CDR(vcell);
-}
-
-
-SCM_PROC(s_symbol_interned_p, "symbol-interned?", 2, 0, 0, scm_symbol_interned_p);
-
-SCM
-scm_symbol_interned_p (o, s)
- SCM o;
- SCM s;
-{
- SCM vcell;
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_interned_p);
- if (o == SCM_BOOL_F)
- o = scm_symhash;
- SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_interned_p);
- vcell = scm_sym2ovcell_soft (s, o);
- if (SCM_IMP(vcell) && (o == scm_symhash))
- vcell = scm_sym2ovcell_soft (s, scm_weak_symhash);
- return (SCM_NIMP(vcell)
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-SCM_PROC(s_symbol_bound_p, "symbol-bound?", 2, 0, 0, scm_symbol_bound_p);
-
-SCM
-scm_symbol_bound_p (o, s)
- SCM o;
- SCM s;
-{
- SCM vcell;
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_bound_p);
- if (o == SCM_BOOL_F)
- o = scm_symhash;
- SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_bound_p);
- vcell = scm_sym2ovcell_soft (s, o);
- return (( SCM_NIMP(vcell)
- && (SCM_CDR(vcell) != SCM_UNDEFINED))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-SCM_PROC(s_symbol_set_x, "symbol-set!", 3, 0, 0, scm_symbol_set_x);
-
-SCM
-scm_symbol_set_x (o, s, v)
- SCM o;
- SCM s;
- SCM v;
-{
- SCM vcell;
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG2, s_symbol_set_x);
- if (o == SCM_BOOL_F)
- o = scm_symhash;
- SCM_ASSERT(SCM_NIMP(o) && SCM_VECTORP(o), o, SCM_ARG1, s_symbol_set_x);
- vcell = scm_sym2ovcell (s, o);
- SCM_SETCDR (vcell, v);
- return SCM_UNSPECIFIED;
-}
-
-static void
-msymbolize (s)
- SCM s;
-{
- SCM string;
- string = scm_makfromstr (SCM_CHARS (s), SCM_LENGTH (s), SCM_SYMBOL_SLOTS);
- SCM_SETCHARS (s, SCM_CHARS (string));
- SCM_SETLENGTH (s, SCM_LENGTH (s), scm_tc7_msymbol);
- SCM_SYMBOL_MULTI_BYTE_STRINGP (s) = SCM_BOOL_F;
- SCM_SETCDR (string, SCM_EOL);
- SCM_SETCAR (string, SCM_EOL);
-}
-
-
-SCM_PROC(s_symbol_fref, "symbol-fref", 1, 0, 0, scm_symbol_fref);
-
-SCM
-scm_symbol_fref (s)
- SCM s;
-{
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fref);
- SCM_DEFER_INTS;
- if (SCM_TYP7(s) == scm_tc7_ssymbol)
- msymbolize (s);
- SCM_ALLOW_INTS;
- return SCM_SYMBOL_FUNC (s);
-}
-
-
-SCM_PROC(s_symbol_pref, "symbol-pref", 1, 0, 0, scm_symbol_pref);
-
-SCM
-scm_symbol_pref (s)
- SCM s;
-{
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pref);
- SCM_DEFER_INTS;
- if (SCM_TYP7(s) == scm_tc7_ssymbol)
- msymbolize (s);
- SCM_ALLOW_INTS;
- return SCM_SYMBOL_PROPS (s);
-}
-
-
-SCM_PROC(s_symbol_fset_x, "symbol-fset!", 2, 0, 0, scm_symbol_fset_x);
-
-SCM
-scm_symbol_fset_x (s, val)
- SCM s;
- SCM val;
-{
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_fset_x);
- SCM_DEFER_INTS;
- if (SCM_TYP7(s) == scm_tc7_ssymbol)
- msymbolize (s);
- SCM_ALLOW_INTS;
- SCM_SYMBOL_FUNC (s) = val;
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_symbol_pset_x, "symbol-pset!", 2, 0, 0, scm_symbol_pset_x);
-
-SCM
-scm_symbol_pset_x (s, val)
- SCM s;
- SCM val;
-{
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_pset_x);
- SCM_DEFER_INTS;
- if (SCM_TYP7(s) == scm_tc7_ssymbol)
- msymbolize (s);
- SCM_SYMBOL_PROPS (s) = val;
- SCM_ALLOW_INTS;
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_symbol_hash, "symbol-hash", 1, 0, 0, scm_symbol_hash);
-
-SCM
-scm_symbol_hash (s)
- SCM s;
-{
- SCM_ASSERT(SCM_NIMP(s) && SCM_SYMBOLP(s), s, SCM_ARG1, s_symbol_hash);
- return SCM_MAKINUM ((unsigned long)s ^ SCM_SYMBOL_HASH (s));
-}
-
-
-
-void
-scm_init_symbols ()
-{
-#include "symbols.x"
-}
-
diff --git a/libguile/symbols.h b/libguile/symbols.h
deleted file mode 100644
index f8a75d5f3..000000000
--- a/libguile/symbols.h
+++ /dev/null
@@ -1,132 +0,0 @@
-/* classes: h_files */
-
-#ifndef SYMBOLSH
-#define SYMBOLSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-extern int scm_symhash_dim;
-
-/* SCM_LENGTH(SYM) is the length of SYM's name in characters, and
- SCM_CHARS(SYM) is the address of the first character of SYM's name.
-
- Beyond that, there are two kinds of symbols: ssymbols and msymbols,
- distinguished by the 'S' bit in the type.
-
- Ssymbols are just uniquified strings. They have a length, chars,
- and that's it. They use the scm_tc7_ssymbol tag (S bit clear).
-
- Msymbols are symbols with extra slots. These slots hold a property
- list and a function value (for Emacs Lisp compatibility), a hash
- code, and a flag to indicate whether their name contains multibyte
- characters. They use the scm_tc7_msymbol tag.
-
- We'd like SCM_CHARS to work on msymbols just as it does on
- ssymbols, so we'll have it point to the symbol's name as usual, and
- store a pointer to the slots just before the name in memory. Thus,
- you have to do some casting and pointer arithmetic to find the
- slots; see the SCM_SLOTS macro.
-
- In practice, the slots always live just before the pointer to them.
- So why not ditch the pointer, and use negative indices to refer to
- the slots? That's a good question; ask the author. I think it was
- the cognac. */
-
-#define SCM_SYMBOLP(x) (SCM_TYP7S(x)==scm_tc7_ssymbol)
-#define SCM_LENGTH(x) (((unsigned long)SCM_CAR(x))>>8)
-#define SCM_LENGTH_MAX (0xffffffL)
-#define SCM_SETLENGTH(x, v, t) SCM_SETCAR((x), ((v)<<8)+(t))
-#define SCM_SETCHARS SCM_SETCDR
-#define SCM_CHARS(x) ((char *)(SCM_CDR(x)))
-#define SCM_UCHARS(x) ((unsigned char *)(SCM_CDR(x)))
-#define SCM_SLOTS(x) ((SCM *) (* ((SCM *)SCM_CHARS(x) - 1)))
-#define SCM_SYMBOL_SLOTS 5
-#define SCM_SYMBOL_FUNC(X) (SCM_SLOTS(X)[0])
-#define SCM_SYMBOL_PROPS(X) (SCM_SLOTS(X)[1])
-#define SCM_SYMBOL_HASH(X) (*(unsigned long*)(&SCM_SLOTS(X)[2]))
-#define SCM_SYMBOL_MULTI_BYTE_STRINGP(X) (*(unsigned long*)(&SCM_SLOTS(X)[3]))
-
-#define SCM_ROSTRINGP(x) ((SCM_TYP7SD(x)==scm_tc7_string) || (SCM_TYP7S(x) == scm_tc7_ssymbol))
-#define SCM_ROCHARS(x) ((SCM_TYP7(x) == scm_tc7_substring) \
- ? SCM_INUM (SCM_CADR (x)) + SCM_CHARS (SCM_CDDR (x)) \
- : SCM_CHARS (x))
-#define SCM_ROUCHARS(x) ((SCM_TYP7(x) == scm_tc7_substring) \
- ? SCM_INUM (SCM_CADR (x)) + SCM_UCHARS (SCM_CDDR (x)) \
- : SCM_UCHARS (x))
-#define SCM_ROLENGTH(x) SCM_LENGTH (x)
-#define SCM_SUBSTRP(x) ((SCM_TYP7S(x) == scm_tc7_substring))
-#define SCM_SUBSTR_STR(x) (SCM_CDDR (x))
-#define SCM_SUBSTR_OFFSET(x) (SCM_CADR (x))
-
-
-
-
-extern unsigned long scm_strhash SCM_P ((unsigned char *str, scm_sizet len, unsigned long n));
-extern SCM scm_sym2vcell SCM_P ((SCM sym, SCM thunk, SCM definep));
-extern SCM scm_sym2ovcell_soft SCM_P ((SCM sym, SCM obarray));
-extern SCM scm_sym2ovcell SCM_P ((SCM sym, SCM obarray));
-extern SCM scm_intern_obarray_soft SCM_P ((char *name, scm_sizet len, SCM obarray, int softness));
-extern SCM scm_intern_obarray SCM_P ((char *name, scm_sizet len, SCM obarray));
-extern SCM scm_intern SCM_P ((char *name, scm_sizet len));
-extern SCM scm_intern0 SCM_P ((char * name));
-extern SCM scm_sysintern SCM_P ((char *name, SCM val));
-extern SCM scm_symbol_p SCM_P ((SCM x));
-extern SCM scm_symbol_to_string SCM_P ((SCM s));
-extern SCM scm_string_to_symbol SCM_P ((SCM s));
-extern SCM scm_string_to_obarray_symbol SCM_P ((SCM o, SCM s, SCM softp));
-extern SCM scm_intern_symbol SCM_P ((SCM o, SCM s));
-extern SCM scm_unintern_symbol SCM_P ((SCM o, SCM s));
-extern SCM scm_symbol_binding SCM_P ((SCM o, SCM s));
-extern SCM scm_symbol_interned_p SCM_P ((SCM o, SCM s));
-extern SCM scm_symbol_bound_p SCM_P ((SCM o, SCM s));
-extern SCM scm_symbol_set_x SCM_P ((SCM o, SCM s, SCM v));
-extern SCM scm_symbol_fref SCM_P ((SCM s));
-extern SCM scm_symbol_pref SCM_P ((SCM s));
-extern SCM scm_symbol_fset_x SCM_P ((SCM s, SCM val));
-extern SCM scm_symbol_pset_x SCM_P ((SCM s, SCM val));
-extern SCM scm_symbol_hash SCM_P ((SCM s));
-extern void scm_init_symbols SCM_P ((void));
-
-#endif /* SYMBOLSH */
diff --git a/libguile/tag.c b/libguile/tag.c
deleted file mode 100644
index 09f0effe5..000000000
--- a/libguile/tag.c
+++ /dev/null
@@ -1,215 +0,0 @@
-/* Copyright (C) 1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-#include "struct.h"
-
-#include "tag.h"
-
-
-SCM_CONST_LONG (scm_utag_immediate_integer, "utag_immediate_integer", 0);
-SCM_CONST_LONG (scm_utag_immediate_char, "utag_immediate_char", 1);
-SCM_CONST_LONG (scm_utag_pair, "utag_pair", 2);
-SCM_CONST_LONG (scm_utag_closure, "utag_closure", 3);
-SCM_CONST_LONG (scm_utag_symbol, "utag_symbol", 4);
-SCM_CONST_LONG (scm_utag_vector, "utag_vector", 5);
-SCM_CONST_LONG (scm_utag_wvect, "utag_wvect", 6);
-SCM_CONST_LONG (scm_utag_bvect, "utag_bvect", 7);
-SCM_CONST_LONG (scm_utag_byvect, "utag_byvect", 8);
-SCM_CONST_LONG (scm_utag_svect, "utag_svect", 9);
-SCM_CONST_LONG (scm_utag_ivect, "utag_ivect", 10);
-SCM_CONST_LONG (scm_utag_uvect, "utag_uvect", 11);
-SCM_CONST_LONG (scm_utag_fvect, "utag_fvect", 12);
-SCM_CONST_LONG (scm_utag_dvect, "utag_dvect", 13);
-SCM_CONST_LONG (scm_utag_cvect, "utag_cvect", 14);
-SCM_CONST_LONG (scm_utag_string, "utag_string", 15);
-SCM_CONST_LONG (scm_utag_mb_string, "utag_mb_string", 16);
-SCM_CONST_LONG (scm_utag_substring, "utag_substring", 17);
-SCM_CONST_LONG (scm_utag_mb_substring, "utag_mb_substring", 18);
-SCM_CONST_LONG (scm_utag_asubr, "utag_asubr", 19);
-SCM_CONST_LONG (scm_utag_subr_0, "utag_subr_0", 20);
-SCM_CONST_LONG (scm_utag_subr_1, "utag_subr_1", 21);
-SCM_CONST_LONG (scm_utag_cxr, "utag_cxr", 22);
-SCM_CONST_LONG (scm_utag_subr_3, "utag_subr_3", 23);
-SCM_CONST_LONG (scm_utag_subr_2, "utag_subr_2", 24);
-SCM_CONST_LONG (scm_utag_rpsubr, "utag_rpsubr", 25);
-SCM_CONST_LONG (scm_utag_subr_1o, "utag_subr_1o", 26);
-SCM_CONST_LONG (scm_utag_subr_2o, "utag_subr_2o", 27);
-SCM_CONST_LONG (scm_utag_lsubr_2, "utag_lsubr_2", 28);
-SCM_CONST_LONG (scm_utag_lsubr, "utag_lsubr", 29);
-SCM_CONST_LONG (scm_utag_smob_base, "utag_smob_base", 252);
-SCM_CONST_LONG (scm_utag_port_base, "utag_port_base", 253);
-SCM_CONST_LONG (scm_utag_flag_base, "utag_flag_base", 254);
-SCM_CONST_LONG (scm_utag_struct_base, "utag_struct_base", 255);
-
-
-SCM_PROC (s_tag, "tag", 1, 0, 0, scm_tag);
-
-SCM
-scm_tag (x)
- SCM x;
-{
- switch (SCM_ITAG3 (x))
- {
- case scm_tc3_int_1:
- case scm_tc3_int_2:
- return SCM_CDR (scm_utag_immediate_integer) ;
-
- case scm_tc3_imm24:
- if (SCM_ICHRP (x))
- return SCM_CDR (scm_utag_immediate_char) ;
- else
- {
- int tag;
- tag = SCM_MAKINUM ((x >> 8) & 0xff);
- return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_flag_base) ) | (tag << 8));
- }
-
- case scm_tc3_cons:
- switch (SCM_TYP7 (x))
- {
- case scm_tcs_cons_nimcar:
- return SCM_CDR (scm_utag_pair) ;
- case scm_tcs_closures:
- return SCM_CDR (scm_utag_closure) ;
- case scm_tcs_symbols:
- return SCM_CDR (scm_utag_symbol) ;
- case scm_tc7_vector:
- return SCM_CDR (scm_utag_vector) ;
- case scm_tc7_wvect:
- return SCM_CDR (scm_utag_wvect) ;
- case scm_tc7_bvect:
- return SCM_CDR (scm_utag_bvect) ;
- case scm_tc7_byvect:
- return SCM_CDR (scm_utag_byvect) ;
- case scm_tc7_svect:
- return SCM_CDR (scm_utag_svect) ;
- case scm_tc7_ivect:
- return SCM_CDR (scm_utag_ivect) ;
- case scm_tc7_uvect:
- return SCM_CDR (scm_utag_uvect) ;
- case scm_tc7_fvect:
- return SCM_CDR (scm_utag_fvect) ;
- case scm_tc7_dvect:
- return SCM_CDR (scm_utag_dvect) ;
- case scm_tc7_cvect:
- return SCM_CDR (scm_utag_cvect) ;
- case scm_tc7_string:
- return SCM_CDR (scm_utag_string) ;
- case scm_tc7_mb_string:
- return SCM_CDR (scm_utag_mb_string) ;
- case scm_tc7_substring:
- return SCM_CDR (scm_utag_substring) ;
- case scm_tc7_mb_substring:
- return SCM_CDR (scm_utag_mb_substring) ;
- case scm_tc7_asubr:
- return SCM_CDR (scm_utag_asubr) ;
- case scm_tc7_subr_0:
- return SCM_CDR (scm_utag_subr_0) ;
- case scm_tc7_subr_1:
- return SCM_CDR (scm_utag_subr_1) ;
- case scm_tc7_cxr:
- return SCM_CDR (scm_utag_cxr) ;
- case scm_tc7_subr_3:
- return SCM_CDR (scm_utag_subr_3) ;
- case scm_tc7_subr_2:
- return SCM_CDR (scm_utag_subr_2) ;
- case scm_tc7_rpsubr:
- return SCM_CDR (scm_utag_rpsubr) ;
- case scm_tc7_subr_1o:
- return SCM_CDR (scm_utag_subr_1o) ;
- case scm_tc7_subr_2o:
- return SCM_CDR (scm_utag_subr_2o) ;
- case scm_tc7_lsubr_2:
- return SCM_CDR (scm_utag_lsubr_2) ;
- case scm_tc7_lsubr:
- return SCM_CDR (scm_utag_lsubr) ;
-
- case scm_tc7_port:
- {
- int tag;
- tag = (SCM_TYP16 (x) >> 8) & 0xff;
- return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_port_base)) | (tag << 8));
- }
- case scm_tc7_smob:
- {
- int tag;
- tag = (SCM_TYP16 (x) >> 8) & 0xff;
- return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_smob_base)) | (tag << 8));
- }
- case scm_tcs_cons_gloc:
- /* must be a struct */
- {
- int tag;
- tag = SCM_STRUCT_VTABLE_DATA (x)[scm_struct_i_tag];
- return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_struct_base)) | (tag << 8));
- }
- return SCM_CDR (scm_utag_struct_base) ;
-
- default:
- if (SCM_CONSP (x))
- return SCM_CDR (scm_utag_pair);
- else
- return SCM_MAKINUM (-1);
- }
-
- case scm_tc3_cons_gloc:
- case scm_tc3_tc7_1:
- case scm_tc3_tc7_2:
- case scm_tc3_closure:
- /* Never reached */
- break;
- }
- return SCM_MAKINUM (-1);
-}
-
-
-
-
-
-void
-scm_init_tag ()
-{
-#include "tag.x"
-}
-
diff --git a/libguile/tag.h b/libguile/tag.h
deleted file mode 100644
index 9c4952bdf..000000000
--- a/libguile/tag.h
+++ /dev/null
@@ -1,58 +0,0 @@
-/* classes: h_files */
-
-#ifndef TAGH
-#define TAGH
-/* Copyright (C) 1995 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-
-
-
-
-extern SCM scm_tag SCM_P ((SCM x));
-extern void scm_init_tag SCM_P ((void));
-
-#endif /* TAGH */
diff --git a/libguile/tags.h b/libguile/tags.h
deleted file mode 100644
index 1b21ba8c9..000000000
--- a/libguile/tags.h
+++ /dev/null
@@ -1,539 +0,0 @@
-/* classes: h_files */
-
-#ifndef TAGSH
-#define TAGSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-/** This file defines the format of SCM values and cons pairs.
- ** It is here that tag bits are assigned for various purposes.
- **/
-
-
-
-/* In the beginning was the Word:
- */
-typedef long SCM;
-
-
-
-/* Cray machines have pointers that are incremented once for each word,
- * rather than each byte, the 3 most significant bits encode the byte
- * within the word. The following macros deal with this by storing the
- * native Cray pointers like the ones that looks like scm expects. This
- * is done for any pointers that might appear in the car of a scm_cell, pointers
- * to scm_vector elts, functions, &c are not munged.
- */
-#ifdef _UNICOS
-# define SCM2PTR(x) ((int)(x) >> 3)
-# define PTR2SCM(x) (((SCM)(x)) << 3)
-# define SCM_POINTERS_MUNGED
-#else
-# define SCM2PTR(x) (x)
-# define PTR2SCM(x) ((SCM)(x))
-#endif /* def _UNICOS */
-
-
-/* SCM variables can contain:
- *
- * Non-objects -- meaning that the tag-related macros don't apply to them
- * in the usual way.
- *
- * Immediates -- meaning that the variable contains an entire Scheme object.
- *
- * Non-immediates -- meaning that the variable holds a (possibly
- * tagged) pointer into the cons pair heap.
- *
- * Non-objects are distinguished from other values by careful coding
- * only (i.e., programmers must keep track of any SCM variables they
- * create that don't contain ordinary scheme values).
- *
- * All immediates and non-immediates must have a 0 in bit 0. Only
- * non-object values can have a 1 in bit 0. In some cases, bit 0 of a
- * word in the heap is used for the GC tag so during garbage
- * collection, that bit might be 1 even in an immediate or
- * non-immediate value. In other cases, bit 0 of a word in the heap
- * is used to tag a pointer to a GLOC (VM global variable address) or
- * the header of a struct. But whenever an SCM variable holds a
- * normal Scheme value, bit 0 is 0.
- *
- * Immediates and non-immediates are distinguished by bits two and four.
- * Immediate values must have a 1 in at least one of those bits. Does
- * this (or any other detail of tagging) seem arbitrary? Try changing it!
- * (Not always impossible but it is fair to say that many details of tags
- * are mutually dependent). */
-
-#define SCM_IMP(x) (6 & (int)(x))
-#define SCM_NIMP(x) (!SCM_IMP(x))
-
-/* Here is a summary of tagging in SCM values as they might occur in
- * SCM variables or in the heap.
- *
- * low bits meaning
- *
- *
- * 0 Most objects except...
- * 1 ...glocs and structs (this tag valid only in a SCM_CAR or
- * in the header of a struct's data).
- *
- * 00 heap addresses and many immediates (not integers)
- * 01 glocs/structs, some tc7_ codes
- * 10 immediate integers
- * 11 various tc7_ codes including, tc16_ codes.
- *
- *
- * 000 heap address
- * 001 glocs/structs
- * 010 integer
- * 011 closure
- * 100 immediates
- * 101 tc7_
- * 110 integer
- * 111 tc7_
- *
- *
- * 100 --- IMMEDIATES
- *
- * Looking at the seven final bits of an immediate:
- *
- * 0000-100 short instruction
- * 0001-100 short instruction
- * 0010-100 short instruction
- * 0011-100 short instruction
- * 0100-100 short instruction
- * 0101-100 short instruction
- * 0110-100 various immediates and long instructions
- * 0111-100 short instruction
- * 1000-100 short instruction
- * 1001-100 short instruction
- * 1010-100 short instruction
- * 1011-100 short instruction
- * 1100-100 short instruction
- * 1101-100 short instruction
- * 1110-100 immediate characters
- * 1111-100 ilocs
- *
- * Some of the 0110100 immediates are long instructions (they dispatch
- * in two steps compared to one step for a short instruction).
- * The two steps are, (1) dispatch on 7 bits to the long instruction
- * handler, (2) dispatch on 7 additional bits.
- *
- * One way to think of it is that there are 128 short instructions,
- * with the 13 immediates above being some of the most interesting.
- *
- * Also noteworthy are the groups of 16 7-bit instructions implied by
- * some of the 3-bit tags. For example, closure references consist
- * of an 8-bit aligned address tagged with 011. There are 16 identical 7-bit
- * instructions, all ending 011, which are invoked by evaluating closures.
- *
- * In other words, if you hand the evaluator a closure, the evaluator
- * treats the closure as a graph of virtual machine instructions.
- * A closure is a pair with a pointer to the body of the procedure
- * in the CDR and a pointer to the environment of the closure in the CAR.
- * The environment pointer is tagged 011 which implies that the least
- * significant 7 bits of the environment pointer also happen to be
- * a virtual machine instruction we could call "SELF" (for self-evaluating
- * object).
- *
- * A less trivial example are the 16 instructions ending 000. If those
- * bits tag the CAR of a pair, then evidently the pair is an ordinary
- * cons pair and should be evaluated as a procedure application. The sixteen,
- * 7-bit 000 instructions are all "NORMAL-APPLY" (Things get trickier.
- * For example, if the CAR of a procedure application is a symbol, the NORMAL-APPLY
- * instruction will, as a side effect, overwrite that CAR with a new instruction
- * that contains a cached address for the variable named by the symbol.)
- *
- * Here is a summary of tags in the CAR of a non-immediate:
- *
- * HEAP CELL: G=gc_mark; 1 during mark, 0 other times.
- *
- * cons ..........SCM car..............0 ...........SCM cdr.............G
- * gloc ..........SCM vcell..........001 ...........SCM cdr.............G
- * struct ..........void * type........001 ...........void * data.........G
- * closure ..........SCM code...........011 ...........SCM env.............G
- * tc7 .........long length....GxxxD1S1 ..........void *data............
- *
- *
- *
- * 101 & 111 --- tc7_ types
- *
- * tc7_tags are 7 bit tags ending in 1x1. These tags
- * occur only in the CAR of heap cells, and have the
- * handy property that all bits of the CAR above the
- * bottom eight can be used to store a length, thus
- * saving a word in the body itself. Thus, we use them
- * for strings, symbols, and vectors (among other
- * things).
- *
- * SCM_LENGTH returns the bits in "length" (see the diagram).
- * SCM_CHARS returns the data cast to "char *"
- * SCM_CDR returns the data cast to "SCM"
- * TYP7(X) returns bits 0...6 of SCM_CAR (X)
- *
- * For the interpretation of SCM_LENGTH and SCM_CHARS
- * that applies to a particular type, see the header file
- * for that type.
- *
- * Sometimes we choose the bottom seven bits carefully,
- * so that the 4- and 1-valued bits (called the D and S
- * bits) can be masked off to reveal a common type.
- *
- * TYP7S(X) returns TYP7, but masking out the option bit S.
- * TYP7D(X) returns TYP7, but masking out the option bit D.
- * TYP7SD(X) masks out both option bits.
- *
- * For example, all strings have 001 in the 'xxx' bits in
- * the diagram above, the D bit says whether it's a
- * substring, and the S bit says whether it's a multibyte
- * character string.
- *
- * for example:
- * D S
- * scm_tc7_string = G0010101
- * scm_tc7_mb_string = G0010111
- * scm_tc7_substring = G0011101
- * scm_tc7_mb_substring = G0011111
- *
- * TYP7DS turns all string tags into tc7_string; thus,
- * testing TYP7DS against tc7_string is a quick way to
- * test for any kind of string.
- *
- * TYP7S turns tc7_mb_string into tc7_string and
- * tc7_mb_substring into tc7_substring.
- *
- * TYP7D turns tc7_mb_substring into tc7_mb_string and
- * tc7_substring into tc7_string.
- *
- * Some TC7 types are subdivided into 256 subtypes giving
- * rise to the macros:
- *
- * TYP16
- * TYP16S
- * GCTYP16
- *
- * TYP16S functions similarly wrt to TYP16 as TYP7S to TYP7,
- * but a different option bit is used (bit 2 for TYP7S,
- * bit 8 for TYP16S).
- * */
-
-
-
-
-/* {Non-immediate values.}
- *
- * If X is non-immediate, it is necessary to look at SCM_CAR (X) to
- * figure out Xs type. X may be a cons pair, in which case the
- * value SCM_CAR (x) will be either an immediate or non-immediate value.
- * X may be something other than a cons pair, in which case the value SCM_CAR (x)
- * will be a non-object value.
- *
- * All immediates and non-immediates have a 0 in bit 0. We additionally preserve
- * the invariant that all non-object values stored in the SCM_CAR of a non-immediate
- * object have a 1 in bit 1:
- */
-
-#define SCM_NCONSP(x) (1 & (int)SCM_CAR(x))
-#define SCM_CONSP(x) (!SCM_NCONSP(x))
-
-
-/* ECONSP is historical and, in fact, slightly buggy.
- * There are two places to fix where structures and glocs can be confused.
- * !!!
- */
-#define SCM_ECONSP(x) (SCM_CONSP(x) || (1==SCM_TYP3(x)))
-#define SCM_NECONSP(x) (SCM_NCONSP(x) && (1 != SCM_TYP3(x)))
-
-
-
-#define SCM_CELLP(x) (!SCM_NCELLP(x))
-#define SCM_NCELLP(x) ((sizeof(scm_cell)-1) & (int)(x))
-
-/* See numbers.h for macros relating to immediate integers.
- */
-
-#define SCM_ITAG3(x) (7 & (int)x)
-#define SCM_TYP3(x) (7 & (int)SCM_CAR(x))
-#define scm_tc3_cons 0
-#define scm_tc3_cons_gloc 1
-#define scm_tc3_int_1 2
-#define scm_tc3_closure 3
-#define scm_tc3_imm24 4
-#define scm_tc3_tc7_1 5
-#define scm_tc3_int_2 6
-#define scm_tc3_tc7_2 7
-
-
-/*
- * Do not change the three bit tags.
- */
-
-
-#define SCM_TYP7(x) (0x7f & (int)SCM_CAR(x))
-#define SCM_TYP7S(x) (0x7d & (int)SCM_CAR(x))
-#define SCM_TYP7SD(x) (0x75 & (int)SCM_CAR(x))
-#define SCM_TYP7D(x) (0x77 & (int)SCM_CAR(x))
-
-
-#define SCM_TYP16(x) (0xffff & (int)SCM_CAR(x))
-#define SCM_TYP16S(x) (0xfeff & (int)SCM_CAR(x))
-#define SCM_GCTYP16(x) (0xff7f & (int)SCM_CAR(x))
-
-
-
-/* Testing and Changing GC Marks in Various Standard Positions
- */
-#define SCM_GCMARKP(x) (1 & (int)SCM_CDR(x))
-#define SCM_GC8MARKP(x) (0x80 & (int)SCM_CAR(x))
-#define SCM_SETGCMARK(x) SCM_SETOR_CDR (x,1)
-#define SCM_CLRGCMARK(x) SCM_SETAND_CDR (x, ~1L)
-#define SCM_SETGC8MARK(x) SCM_SETOR_CAR (x, 0x80)
-#define SCM_CLRGC8MARK(x) SCM_SETAND_CAR (x, ~0x80L)
-
-
-
-
-/* couple */
-#define scm_tc7_ssymbol 5
-#define scm_tc7_msymbol 7
-
-/* couple */
-#define scm_tc7_vector 13
-#define scm_tc7_wvect 15
-
-/* a quad, two couples, two trists */
-#define scm_tc7_string 21
-#define scm_tc7_mb_string 23
-#define scm_tc7_substring 29
-#define scm_tc7_mb_substring 31
-
-/* Many of the following should be turned
- * into structs or smobs. We need back some
- * of these 7 bit tags!
- */
-#define scm_tc7_uvect 37
-#define scm_tc7_lvector 39
-#define scm_tc7_fvect 45
-#define scm_tc7_dvect 47
-#define scm_tc7_cvect 53
-#define scm_tc7_svect 55
-#define scm_tc7_contin 61
-#define scm_tc7_cclo 63
-#define scm_tc7_rpsubr 69
-#define scm_tc7_bvect 71
-#define scm_tc7_byvect 77
-#define scm_tc7_ivect 79
-#define scm_tc7_subr_0 85
-#define scm_tc7_subr_1 87
-#define scm_tc7_cxr 93
-#define scm_tc7_subr_3 95
-#define scm_tc7_subr_2 101
-#define scm_tc7_asubr 103
-#define scm_tc7_subr_1o 109
-#define scm_tc7_subr_2o 111
-#define scm_tc7_lsubr_2 117
-#define scm_tc7_lsubr 119
-
-
-/* There are 256 port subtypes. Here are the first four.
- * These must agree with the init function in ports.c
- */
-#define scm_tc7_port 125
-
-/* fports and pipes form an intended TYP16S equivelancy
- * group (similar to a tc7 "couple".
- */
-#define scm_tc16_fport (scm_tc7_port + 0*256L)
-#define scm_tc16_pipe (scm_tc7_port + 1*256L)
-
-#define scm_tc16_strport (scm_tc7_port + 2*256L)
-#define scm_tc16_sfport (scm_tc7_port + 3*256L)
-
-
-/* There are 256 smob subtypes. Here are the first four.
- */
-
-#define scm_tc7_smob 127 /* DO NOT CHANGE [**] */
-
-/* [**] If you change scm_tc7_smob, you must also change
- * the places it is hard coded in this file and possibly others.
- */
-
-
-/* scm_tc_free_cell is also the 0th smob type.
- */
-#define scm_tc_free_cell 127
-
-/* The 1st smob type:
- */
-#define scm_tc16_flo 0x017f
-#define scm_tc_flo 0x017fL
-
-/* Some option bits begeinning at bit 16 of scm_tc16_flo:
- */
-#define SCM_REAL_PART (1L<<16)
-#define SCM_IMAG_PART (2L<<16)
-#define scm_tc_dblr (scm_tc16_flo|SCM_REAL_PART)
-#define scm_tc_dblc (scm_tc16_flo|SCM_REAL_PART|SCM_IMAG_PART)
-
-
-/* Smob types 2 and 3:
- */
-#define scm_tc16_bigpos 0x027f
-#define scm_tc16_bigneg 0x037f
-
-
-
-/* {Immediate Values}
- */
-
-enum scm_tags
-{
- scm_tc8_char = 0xf4,
- scm_tc8_iloc = 0xfc,
-};
-
-#define SCM_ITAG8(X) ((int)(X) & 0xff)
-#define SCM_MAKE_ITAG8(X, TAG) (((X)<<8) + TAG)
-#define SCM_ITAG8_DATA(X) ((X)>>8)
-
-
-
-/* Immediate Symbols, Special Symbols, Flags (various constants).
- */
-
-/* SCM_ISYMP tests for ISPCSYM and ISYM */
-#define SCM_ISYMP(n) ((0x187 & (int)(n))==4)
-
-/* SCM_IFLAGP tests for ISPCSYM, ISYM and IFLAG */
-#define SCM_IFLAGP(n) ((0x87 & (int)(n))==4)
-#define SCM_ISYMNUM(n) ((int)((n)>>9))
-#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM(n)])
-#define SCM_MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L)
-#define SCM_MAKISYM(n) (((n)<<9)+0x74L)
-#define SCM_MAKIFLAG(n) (((n)<<9)+0x174L)
-
-/* This table must agree with the declarations
- * in repl.c: {Names of immediate symbols}.
- *
- * These are used only in eval but their values
- * have to be allocated here.
- *
- */
-
-#define SCM_IM_AND SCM_MAKSPCSYM(0)
-#define SCM_IM_BEGIN SCM_MAKSPCSYM(1)
-#define SCM_IM_CASE SCM_MAKSPCSYM(2)
-#define SCM_IM_COND SCM_MAKSPCSYM(3)
-#define SCM_IM_DO SCM_MAKSPCSYM(4)
-#define SCM_IM_IF SCM_MAKSPCSYM(5)
-#define SCM_IM_LAMBDA SCM_MAKSPCSYM(6)
-#define SCM_IM_LET SCM_MAKSPCSYM(7)
-#define SCM_IM_LETSTAR SCM_MAKSPCSYM(8)
-#define SCM_IM_LETREC SCM_MAKSPCSYM(9)
-#define SCM_IM_OR SCM_MAKSPCSYM(10)
-#define SCM_IM_QUOTE SCM_MAKSPCSYM(11)
-#define SCM_IM_SET SCM_MAKSPCSYM(12)
-#define SCM_IM_DEFINE SCM_MAKSPCSYM(13)
-#define SCM_IM_APPLY SCM_MAKISYM(14)
-#define SCM_IM_CONT SCM_MAKISYM(15)
-#define SCM_BOOL_F SCM_MAKIFLAG(16)
-#define SCM_BOOL_T SCM_MAKIFLAG(17)
-#define SCM_UNDEFINED SCM_MAKIFLAG(18)
-#define SCM_EOF_VAL SCM_MAKIFLAG(19)
-#define SCM_EOL SCM_MAKIFLAG(20)
-#define SCM_UNSPECIFIED SCM_MAKIFLAG(21)
-
-
-#define SCM_UNBNDP(x) (SCM_UNDEFINED==(x))
-
-
-
-/* Dispatching aids:
- */
-
-
-/* For cons pairs with immediate values in the CAR
- */
-
-#define scm_tcs_cons_imcar 2:case 4:case 6:case 10:\
- case 12:case 14:case 18:case 20:\
- case 22:case 26:case 28:case 30:\
- case 34:case 36:case 38:case 42:\
- case 44:case 46:case 50:case 52:\
- case 54:case 58:case 60:case 62:\
- case 66:case 68:case 70:case 74:\
- case 76:case 78:case 82:case 84:\
- case 86:case 90:case 92:case 94:\
- case 98:case 100:case 102:case 106:\
- case 108:case 110:case 114:case 116:\
- case 118:case 122:case 124:case 126
-
-/* For cons pairs with non-immediate values in the SCM_CAR
- */
-#define scm_tcs_cons_nimcar 0:case 8:case 16:case 24:\
- case 32:case 40:case 48:case 56:\
- case 64:case 72:case 80:case 88:\
- case 96:case 104:case 112:case 120
-
-/* A CONS_GLOC occurs in code. It's CAR is a pointer to the
- * CDR of a variable. The low order bits of the CAR are 001.
- * The CDR of the gloc is the code continuation.
- */
-#define scm_tcs_cons_gloc 1:case 9:case 17:case 25:\
- case 33:case 41:case 49:case 57:\
- case 65:case 73:case 81:case 89:\
- case 97:case 105:case 113:case 121
-
-#define scm_tcs_closures 3:case 11:case 19:case 27:\
- case 35:case 43:case 51:case 59:\
- case 67:case 75:case 83:case 91:\
- case 99:case 107:case 115:case 123
-
-#define scm_tcs_subrs scm_tc7_asubr:case scm_tc7_subr_0:case scm_tc7_subr_1:case scm_tc7_cxr:\
- case scm_tc7_subr_3:case scm_tc7_subr_2:case scm_tc7_rpsubr:case scm_tc7_subr_1o:\
- case scm_tc7_subr_2o:case scm_tc7_lsubr_2:case scm_tc7_lsubr
-
-#define scm_tcs_symbols scm_tc7_ssymbol:case scm_tc7_msymbol
-
-#define scm_tcs_bignums scm_tc16_bigpos:case scm_tc16_bigneg
-
-#endif /* TAGSH */
diff --git a/libguile/throw.c b/libguile/throw.c
deleted file mode 100644
index 7e67df4da..000000000
--- a/libguile/throw.c
+++ /dev/null
@@ -1,496 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "genio.h"
-#include "smob.h"
-#include "alist.h"
-#include "eval.h"
-#include "dynwind.h"
-#include "backtrace.h"
-#ifdef DEBUG_EXTENSIONS
-#include "debug.h"
-#endif
-#include "continuations.h"
-#include "stackchk.h"
-
-#include "throw.h"
-
-
-/* {Catch and Throw}
- */
-static int scm_tc16_jmpbuffer;
-
-#define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer)
-#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
-#define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L)))
-#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L)))
-
-#ifndef DEBUG_EXTENSIONS
-#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
-#define SETJBJMPBUF SCM_SETCDR
-#else
-#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) )
-#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
-#define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X))
-#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
-
-static scm_sizet freejb SCM_P ((SCM jbsmob));
-
-static scm_sizet
-freejb (jbsmob)
- SCM jbsmob;
-{
- scm_must_free ((char *) SCM_CDR (jbsmob));
- return sizeof (scm_cell);
-}
-#endif
-
-static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-static int
-printjb (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port);
- scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
- scm_intprint((SCM) JBJMPBUF(exp), 16, port);
- scm_gen_putc ('>', port);
- return 1 ;
-}
-
-static scm_smobfuns jbsmob = {
- scm_mark0,
-#ifdef DEBUG_EXTENSIONS
- freejb,
-#else
- scm_free0,
-#endif
- printjb,
- 0
-};
-
-static SCM make_jmpbuf SCM_P ((void));
-static SCM
-make_jmpbuf ()
-{
- SCM answer;
- SCM_NEWCELL (answer);
- SCM_REDEFER_INTS;
- {
-#ifdef DEBUG_EXTENSIONS
- char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
- SCM_SETCDR (answer, (SCM) mem);
-#endif
- SCM_SETCAR (answer, scm_tc16_jmpbuffer);
- SETJBJMPBUF(answer, (jmp_buf *)0);
- DEACTIVATEJB(answer);
- }
- SCM_REALLOW_INTS;
- return answer;
-}
-
-struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
-{
- jmp_buf buf; /* must be first */
- SCM throw_tag;
- SCM retval;
-};
-
-
-/* scm_internal_catch is the guts of catch. It handles all the
- mechanics of setting up a catch target, invoking the catch body,
- and perhaps invoking the handler if the body does a throw.
-
- The function is designed to be usable from C code, but is general
- enough to implement all the semantics Guile Scheme expects from
- throw.
-
- TAG is the catch tag. Typically, this is a symbol, but this
- function doesn't actually care about that.
-
- BODY is a pointer to a C function which runs the body of the catch;
- this is the code you can throw from. We call it like this:
- BODY (DATA, JMPBUF)
- where:
- DATA is just the DATA argument we received; we pass it through
- to BODY as its first argument. The caller can make DATA point
- to anything useful that BODY might need.
- JMPBUF is the Scheme jmpbuf object corresponding to this catch,
- which we have just created and initialized.
-
- HANDLER is a pointer to a C function to deal with a throw to TAG,
- should one occur. We call it like this:
- HANDLER (DATA, TAG, THROW_ARGS)
- where
- DATA is the DATA argument we recevied, as for BODY above.
- TAG is the tag that the user threw to; usually this is TAG, but
- it could be something else if TAG was #t (i.e., a catch-all),
- or the user threw to a jmpbuf.
- THROW_ARGS is the list of arguments the user passed to the THROW
- function.
-
- DATA is just a pointer we pass through to BODY and (if we call it)
- HANDLER. We don't actually use it otherwise ourselves. The idea
- is that, if our caller wants to communicate something to BODY and
- HANDLER, it can pass a pointer to it as DATA, which BODY and
- HANDLER can then use. Think of it as a way to make BODY and
- HANDLER closures, not just functions; DATA points to the enclosed
- variables. */
-
-SCM
-scm_internal_catch (tag, body, handler, data)
- SCM tag;
- scm_catch_body_t body;
- scm_catch_handler_t handler;
- void *data;
-{
- struct jmp_buf_and_retval jbr;
- SCM jmpbuf;
- SCM answer;
-
- jmpbuf = make_jmpbuf ();
- answer = SCM_EOL;
- scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
- SETJBJMPBUF(jmpbuf, &jbr.buf);
-#ifdef DEBUG_EXTENSIONS
- SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
-#endif
- if (setjmp (jbr.buf))
- {
- SCM throw_tag;
- SCM throw_args;
-
-#ifdef STACK_CHECKING
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-#endif
- SCM_REDEFER_INTS;
- DEACTIVATEJB (jmpbuf);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
- throw_args = jbr.retval;
- throw_tag = jbr.throw_tag;
- jbr.throw_tag = SCM_EOL;
- jbr.retval = SCM_EOL;
- answer = handler (data, throw_tag, throw_args);
- }
- else
- {
- ACTIVATEJB (jmpbuf);
- answer = body (data, jmpbuf);
- SCM_REDEFER_INTS;
- DEACTIVATEJB (jmpbuf);
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
- }
- return answer;
-}
-
-
-/* scm_catch passes a pointer to one of these structures through to
- its body and handler routines, to tell them what to do. */
-struct catch_body_data
-{
- /* The tag being caught. We only use it to figure out what
- arguments to pass to the body procedure; see catch_body for
- details. */
- SCM tag;
-
- /* The Scheme procedure object constituting the catch body.
- catch_body invokes this. */
- SCM body_proc;
-
- /* The Scheme procedure object we invoke to handle throws. */
- SCM handler_proc;
-};
-
-
-/* This function runs the catch body. DATA contains the Scheme
- procedure to invoke. If the tag being caught is #f, then we pass
- JMPBUF to the body procedure; otherwise, it gets no arguments. */
-static SCM catch_body SCM_P ((void *, SCM));
-
-static SCM
-catch_body (data, jmpbuf)
- void *data;
- SCM jmpbuf;
-{
- struct catch_body_data *c = (struct catch_body_data *) data;
-
- if (c->tag == SCM_BOOL_F)
- return scm_apply (c->body_proc, scm_cons (jmpbuf, SCM_EOL), SCM_EOL);
- else
- return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
-}
-
-
-/* If the user does a throw to this catch, this function runs the
- handler. DATA says which Scheme procedure object to invoke. */
-static SCM catch_handler SCM_P ((void *, SCM, SCM));
-
-static SCM
-catch_handler (data, tag, throw_args)
- void *data;
- SCM tag;
- SCM throw_args;
-{
- struct catch_body_data *c = (struct catch_body_data *) data;
-
- return scm_apply (c->handler_proc, scm_cons (tag, throw_args), SCM_EOL);
-}
-
-
-SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
-SCM
-scm_catch (tag, thunk, handler)
- SCM tag;
- SCM thunk;
- SCM handler;
-{
- struct catch_body_data c;
-
- SCM_ASSERT ((tag == SCM_BOOL_F)
- || (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
- || (tag == SCM_BOOL_T),
- tag, SCM_ARG1, s_catch);
-
- c.tag = tag;
- c.body_proc = thunk;
- c.handler_proc = handler;
-
- /* scm_internal_catch takes care of all the mechanics of setting up
- a catch tag; we tell it to call catch_body to run the body, and
- catch_handler to deal with any throws to this catch. Both those
- functions receive the pointer to c, which tells them the details
- of how to behave. */
- return scm_internal_catch (tag, catch_body, catch_handler, (void *) &c);
-}
-
-SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch);
-SCM
-scm_lazy_catch (tag, thunk, handler)
- SCM tag;
- SCM thunk;
- SCM handler;
-{
- SCM answer;
- SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag))
- || (tag == SCM_BOOL_T),
- tag, SCM_ARG1, s_lazy_catch);
- SCM_REDEFER_INTS;
- scm_dynwinds = scm_acons (tag, handler, scm_dynwinds);
- SCM_REALLOW_INTS;
- answer = scm_apply (thunk, SCM_EOL, SCM_EOL);
- SCM_REDEFER_INTS;
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
- return answer;
-}
-
-/* The user has thrown to an uncaught key --- print a message and die.
- 1) If the user wants something different, they can use (catch #t
- ...) to do what they like.
- 2) Outside the context of a read-eval-print loop, there isn't
- anything else good to do; libguile should not assume the existence
- of a read-eval-print loop.
- 3) Given that we shouldn't do anything complex, it's much more
- robust to do it in C code. */
-static SCM uncaught_throw SCM_P ((SCM key, SCM args));
-static SCM
-uncaught_throw (key, args)
- SCM key;
- SCM args;
-{
- SCM p = scm_def_errp;
-
- if (scm_ilength (args) >= 3)
- {
- SCM message = SCM_CADR (args);
- SCM parts = SCM_CADDR (args);
-
- scm_gen_puts (scm_regular_string, "guile: ", p);
- scm_display_error_message (message, parts, p);
- }
- else
- {
- scm_gen_puts (scm_regular_string, "guile: uncaught throw to ", p);
- scm_prin1 (key, p, 0);
- scm_gen_puts (scm_regular_string, ": ", p);
- scm_prin1 (args, p, 1);
- scm_gen_putc ('\n', p);
- }
-
- exit (2);
-}
-
-
-static char s_throw[];
-SCM
-scm_ithrow (key, args, noreturn)
- SCM key;
- SCM args;
- int noreturn;
-{
- SCM jmpbuf;
- SCM wind_goal;
-
- if (SCM_NIMP (key) && SCM_JMPBUFP (key))
- {
- jmpbuf = key;
- if (noreturn)
- {
- SCM_ASSERT (JBACTIVE (jmpbuf), jmpbuf,
- "throw to dynamically inactive catch",
- s_throw);
- }
- else if (!JBACTIVE (jmpbuf))
- return SCM_UNSPECIFIED;
- }
- else
- {
- SCM dynpair = SCM_UNDEFINED;
- SCM winds;
-
- if (noreturn)
- {
- SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1,
- s_throw);
- }
- else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key)))
- return SCM_UNSPECIFIED;
-
- /* Search the wind list for an appropriate catch.
- "Waiter, please bring us the wind list." */
- for (winds = scm_dynwinds; SCM_NIMP (winds); winds = SCM_CDR (winds))
- {
- if (! SCM_CONSP (winds))
- abort ();
-
- dynpair = SCM_CAR (winds);
- if (SCM_NIMP (dynpair) && SCM_CONSP (dynpair))
- {
- SCM this_key = SCM_CAR (dynpair);
-
- if (this_key == SCM_BOOL_T || this_key == key)
- break;
- }
- }
-
- /* If we didn't find anything, print a message and exit Guile. */
- if (winds == SCM_EOL)
- uncaught_throw (key, args);
-
- if (SCM_IMP (winds) || SCM_NCONSP (winds))
- abort ();
-
- if (dynpair != SCM_BOOL_F)
- jmpbuf = SCM_CDR (dynpair);
- else
- {
- if (!noreturn)
- return SCM_UNSPECIFIED;
- else
- {
- scm_exitval = scm_cons (key, args);
- scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
-#ifdef DEBUG_EXTENSIONS
- scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
-#endif
- longjmp (SCM_JMPBUF (scm_rootcont), 1);
- }
- }
- }
- for (wind_goal = scm_dynwinds;
- SCM_CDAR (wind_goal) != jmpbuf;
- wind_goal = SCM_CDR (wind_goal))
- ;
- if (!SCM_JMPBUFP (jmpbuf))
- {
- SCM oldwinds = scm_dynwinds;
- SCM handle, answer;
- scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
- SCM_REDEFER_INTS;
- handle = scm_dynwinds;
- scm_dynwinds = SCM_CDR (scm_dynwinds);
- SCM_REALLOW_INTS;
- answer = scm_apply (jmpbuf, scm_cons (key, args), SCM_EOL);
- SCM_REDEFER_INTS;
- SCM_SETCDR (handle, scm_dynwinds);
- scm_dynwinds = handle;
- SCM_REALLOW_INTS;
- scm_dowinds (oldwinds, scm_ilength (scm_dynwinds) - scm_ilength (oldwinds));
- return answer;
- }
- else
- {
- struct jmp_buf_and_retval * jbr;
- scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
- jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
- jbr->throw_tag = key;
- jbr->retval = args;
- }
-#ifdef DEBUG_EXTENSIONS
- scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
-#endif
- longjmp (*JBJMPBUF (jmpbuf), 1);
-}
-
-
-SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw);
-SCM
-scm_throw (key, args)
- SCM key;
- SCM args;
-{
- /* May return if handled by lazy catch. */
- return scm_ithrow (key, args, 1);
-}
-
-
-void
-scm_init_throw ()
-{
- scm_tc16_jmpbuffer = scm_newsmob (&jbsmob);
-#include "throw.x"
-}
diff --git a/libguile/throw.h b/libguile/throw.h
deleted file mode 100644
index 83d8e946d..000000000
--- a/libguile/throw.h
+++ /dev/null
@@ -1,65 +0,0 @@
-/* classes: h_files */
-
-#ifndef THROWH
-#define THROWH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-typedef SCM (*scm_catch_body_t) SCM_P ((void *data, SCM jmpbuf));
-typedef SCM (*scm_catch_handler_t) SCM_P ((void *data,
- SCM tag, SCM throw_args));
-
-extern SCM scm_internal_catch SCM_P ((SCM tag,
- scm_catch_body_t body,
- scm_catch_handler_t handler,
- void *data));
-
-extern SCM scm_catch SCM_P ((SCM tag, SCM thunk, SCM handler));
-extern SCM scm_lazy_catch SCM_P ((SCM tag, SCM thunk, SCM handler));
-extern SCM scm_ithrow SCM_P ((SCM key, SCM args, int noreturn));
-extern SCM scm_throw SCM_P ((SCM key, SCM args));
-extern void scm_init_throw SCM_P ((void));
-#endif /* THROWH */
diff --git a/libguile/unif.c b/libguile/unif.c
deleted file mode 100644
index 922101722..000000000
--- a/libguile/unif.c
+++ /dev/null
@@ -1,2538 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-#include "eval.h"
-#include "genio.h"
-#include "smob.h"
-#include "sequences.h"
-#include "strop.h"
-#include "feature.h"
-
-#include "unif.h"
-#include "ramap.h"
-
-
-/* The set of uniform scm_vector types is:
- * Vector of: Called:
- * unsigned char string
- * char byvect
- * boolean bvect
- * signed int ivect
- * unsigned int uvect
- * float fvect
- * double dvect
- * complex double cvect
- * short svect
- * long_long llvect
- */
-
-long scm_tc16_array;
-
-/*
- * This complicates things too much if allowed on any array.
- * C code can safely call it on arrays known to be used in a single
- * threaded manner.
- *
- * SCM_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x);
- */
-static char s_vector_set_length_x[] = "vector-set-length!";
-
-
-SCM
-scm_vector_set_length_x (vect, len)
- SCM vect;
- SCM len;
-{
- long l;
- scm_sizet siz;
- scm_sizet sz;
-
- l = SCM_INUM (len);
- SCM_ASRTGO (SCM_NIMP (vect), badarg1);
- switch (SCM_TYP7 (vect))
- {
- default:
- badarg1: scm_wta (vect, (char *) SCM_ARG1, s_vector_set_length_x);
- case scm_tc7_string:
- case scm_tc7_mb_string:
- SCM_ASRTGO (vect != scm_nullstr, badarg1);
- sz = sizeof (char);
- l++;
- break;
- case scm_tc7_vector:
- SCM_ASRTGO (vect != scm_nullvect, badarg1);
- sz = sizeof (SCM);
- break;
-#ifdef ARRAYS
- case scm_tc7_bvect:
- l = (l + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- sz = sizeof (long);
- break;
- case scm_tc7_byvect:
- sz = sizeof (char);
- break;
-
- case scm_tc7_svect:
- sz = sizeof (short);
- break;
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- sz = sizeof (long_long);
- break;
-#endif
-
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- sz = sizeof (float);
- break;
-#endif
- case scm_tc7_dvect:
- sz = sizeof (double);
- break;
- case scm_tc7_cvect:
- sz = 2 * sizeof (double);
- break;
-#endif
-#endif
- }
- SCM_ASSERT (SCM_INUMP (len), len, SCM_ARG2, s_vector_set_length_x);
- if (!l)
- l = 1L;
- siz = l * sz;
- if (siz != l * sz)
- scm_wta (SCM_MAKINUM (l * sz), (char *) SCM_NALLOC, s_vector_set_length_x);
- SCM_REDEFER_INTS;
- SCM_SETCHARS (vect,
- ((char *)
- scm_must_realloc (SCM_CHARS (vect),
- (long) SCM_LENGTH (vect) * sz,
- (long) siz,
- s_vector_set_length_x)));
- if (SCM_VECTORP (vect))
- {
- sz = SCM_LENGTH (vect);
- while (l > sz)
- SCM_VELTS (vect)[--l] = SCM_UNSPECIFIED;
- }
- else if (SCM_STRINGP (vect))
- SCM_CHARS (vect)[l - 1] = 0;
- SCM_SETLENGTH (vect, SCM_INUM (len), SCM_TYP7 (vect));
- SCM_REALLOW_INTS;
- return vect;
-}
-
-
-#ifdef ARRAYS
-
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
-
-
-SCM
-scm_makflo (x)
- float x;
-{
- SCM z;
- if (x == 0.0)
- return scm_flo0;
- SCM_NEWCELL (z);
- SCM_DEFER_INTS;
- SCM_SETCAR (z, scm_tc_flo);
- SCM_FLO (z) = x;
- SCM_ALLOW_INTS;
- return z;
-}
-#endif
-#endif
-
-
-SCM
-scm_make_uve (k, prot)
- long k;
- SCM prot;
-{
- SCM v;
- long i, type;
- if (SCM_BOOL_T == prot)
- {
- i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
- type = scm_tc7_bvect;
- }
- else if (SCM_ICHRP (prot) && (prot == SCM_MAKICHR ('\0')))
- {
- i = sizeof (char) * k;
- type = scm_tc7_byvect;
- }
- else if (SCM_ICHRP (prot))
- {
- i = sizeof (char) * k;
- type = scm_tc7_string;
- }
- else if (SCM_INUMP (prot))
- {
- i = sizeof (long) * k;
- if (SCM_INUM (prot) > 0)
- type = scm_tc7_uvect;
- else
- type = scm_tc7_ivect;
- }
- else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot)))
- {
- char s;
-
- s = SCM_CHARS (prot)[0];
- if (s == 's')
- {
- i = sizeof (short) * k;
- type = scm_tc7_svect;
- }
-#ifdef LONGLONGS
- else if (s == 'l')
- {
- i = sizeof (long_long) * k;
- type = scm_tc7_llvect;
- }
-#endif
- else
- {
- return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED, SCM_UNDEFINED);
- }
- }
- else
-#ifdef SCM_FLOATS
- if (SCM_IMP (prot) || !SCM_INEXP (prot))
-#endif
- /* Huge non-unif vectors are NOT supported. */
- return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED, SCM_UNDEFINED); /* no special scm_vector */
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- else if (SCM_SINGP (prot))
-
- {
- i = sizeof (float) * k;
- type = scm_tc7_fvect;
- }
-#endif
- else if (SCM_CPLXP (prot))
- {
- i = 2 * sizeof (double) * k;
- type = scm_tc7_cvect;
- }
- else
- {
- i = sizeof (double) * k;
- type = scm_tc7_dvect;
- }
-#endif
-
- SCM_NEWCELL (v);
- SCM_DEFER_INTS;
- {
- char *m;
- m = scm_must_malloc ((i ? i : 1L), "vector");
- SCM_SETCHARS (v, (char *) m);
- }
- SCM_SETLENGTH (v, (k < SCM_LENGTH_MAX ? k : SCM_LENGTH_MAX), type);
- SCM_ALLOW_INTS;
- return v;
-}
-
-SCM_PROC(s_uniform_vector_length, "uniform-vector-length", 1, 0, 0, scm_uniform_vector_length);
-
-SCM
-scm_uniform_vector_length (v)
- SCM v;
-{
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- switch SCM_TYP7
- (v)
- {
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_length);
- case scm_tc7_bvect:
- case scm_tc7_string:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_vector:
- case scm_tc7_svect:
-#ifdef LONGLONGS
- case scm_tc7_llvect:
-#endif
- return SCM_MAKINUM (SCM_LENGTH (v));
- }
-}
-
-SCM_PROC(s_array_p, "array?", 1, 1, 0, scm_array_p);
-
-SCM
-scm_array_p (v, prot)
- SCM v;
- SCM prot;
-{
- int nprot;
- int enclosed;
- nprot = SCM_UNBNDP (prot);
- enclosed = 0;
- if (SCM_IMP (v))
- return SCM_BOOL_F;
-loop:
- switch (SCM_TYP7 (v))
- {
- case scm_tc7_smob:
- if (!SCM_ARRAYP (v))
- return SCM_BOOL_F;
- if (nprot)
- return SCM_BOOL_T;
- if (enclosed++)
- return SCM_BOOL_F;
- v = SCM_ARRAY_V (v);
- goto loop;
- case scm_tc7_bvect:
- return nprot || SCM_BOOL_T==prot ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_string:
- return nprot || (SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'))) ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_byvect:
- return nprot || (prot == SCM_MAKICHR('\0')) ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_uvect:
- return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)>0) ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_ivect:
- return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)<=0) ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_svect:
- return ( nprot
- || (SCM_NIMP (prot)
- && SCM_SYMBOLP (prot)
- && (1 == SCM_LENGTH (prot))
- && ('s' == SCM_CHARS (prot)[0])));
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- return ( nprot
- || (SCM_NIMP (prot)
- && SCM_SYMBOLP (prot)
- && (1 == SCM_LENGTH (prot))
- && ('s' == SCM_CHARS (prot)[0])));
-#endif
-# ifdef SCM_FLOATS
-# ifdef SCM_SINGLES
- case scm_tc7_fvect:
- return nprot || (SCM_NIMP(prot) && SCM_SINGP(prot)) ? SCM_BOOL_T : SCM_BOOL_F;
-# endif
- case scm_tc7_dvect:
- return nprot || (SCM_NIMP(prot) && SCM_REALP(prot)) ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_cvect:
- return nprot || (SCM_NIMP(prot) && SCM_CPLXP(prot)) ? SCM_BOOL_T : SCM_BOOL_F;
-# endif
- case scm_tc7_vector:
- return nprot || SCM_NULLP(prot) ? SCM_BOOL_T : SCM_BOOL_F;
- default:;
- }
- return SCM_BOOL_F;
-}
-
-
-SCM_PROC(s_array_rank, "array-rank", 1, 0, 0, scm_array_rank);
-
-SCM
-scm_array_rank (ra)
- SCM ra;
-{
- if (SCM_IMP (ra))
- return SCM_INUM0;
- switch (SCM_TYP7 (ra))
- {
- default:
- return SCM_INUM0;
- case scm_tc7_string:
- case scm_tc7_vector:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_cvect:
- case scm_tc7_dvect:
-#ifdef LONGLONGS
- case scm_tc7_llvect:
-#endif
- case scm_tc7_svect:
- return SCM_MAKINUM (1L);
- case scm_tc7_smob:
- if (SCM_ARRAYP (ra))
- return SCM_MAKINUM (SCM_ARRAY_NDIM (ra));
- return SCM_INUM0;
- }
-}
-
-
-SCM_PROC(s_array_dimensions, "array-dimensions", 1, 0, 0, scm_array_dimensions);
-
-SCM
-scm_array_dimensions (ra)
- SCM ra;
-{
- SCM res = SCM_EOL;
- scm_sizet k;
- scm_array_dim *s;
- if (SCM_IMP (ra))
- return SCM_BOOL_F;
- switch (SCM_TYP7 (ra))
- {
- default:
- return SCM_BOOL_F;
- case scm_tc7_string:
- case scm_tc7_vector:
- case scm_tc7_bvect:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_cvect:
- case scm_tc7_dvect:
- case scm_tc7_svect:
-#ifdef LONGLONGS
- case scm_tc7_llvect:
-#endif
- return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra)), SCM_EOL);
- case scm_tc7_smob:
- if (!SCM_ARRAYP (ra))
- return SCM_BOOL_F;
- k = SCM_ARRAY_NDIM (ra);
- s = SCM_ARRAY_DIMS (ra);
- while (k--)
- res = scm_cons (s[k].lbnd ? scm_cons2 (SCM_MAKINUM (s[k].lbnd), SCM_MAKINUM (s[k].ubnd), SCM_EOL) :
- SCM_MAKINUM (1 + (s[k].ubnd))
- , res);
- return res;
- }
-}
-
-
-static char s_bad_ind[] = "Bad scm_array index";
-
-
-long
-scm_aind (ra, args, what)
- SCM ra;
- SCM args;
- char *what;
-{
- SCM ind;
- register long j;
- register scm_sizet pos = SCM_ARRAY_BASE (ra);
- register scm_sizet k = SCM_ARRAY_NDIM (ra);
- scm_array_dim *s = SCM_ARRAY_DIMS (ra);
- if (SCM_INUMP (args))
- {
- SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL);
- return pos + (SCM_INUM (args) - s->lbnd) * (s->inc);
- }
- while (k && SCM_NIMP (args))
- {
- ind = SCM_CAR (args);
- args = SCM_CDR (args);
- SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, what);
- j = SCM_INUM (ind);
- SCM_ASSERT (j >= (s->lbnd) && j <= (s->ubnd), ind, SCM_OUTOFRANGE, what);
- pos += (j - s->lbnd) * (s->inc);
- k--;
- s++;
- }
- SCM_ASSERT (0 == k && SCM_NULLP (args), scm_makfrom0str (what), SCM_WNA,
- NULL);
- return pos;
-}
-
-
-
-SCM
-scm_make_ra (ndim)
- int ndim;
-{
- SCM ra;
- SCM_NEWCELL (ra);
- SCM_DEFER_INTS;
- SCM_SETCDR (ra, scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)),
- "array"));
- SCM_SETCAR (ra, ((long) ndim << 17) + scm_tc16_array);
- SCM_ARRAY_V (ra) = scm_nullvect;
- SCM_ALLOW_INTS;
- return ra;
-}
-
-static char s_bad_spec[] = "Bad scm_array dimension";
-/* Increments will still need to be set. */
-
-
-SCM
-scm_shap2ra (args, what)
- SCM args;
- char *what;
-{
- scm_array_dim *s;
- SCM ra, spec, sp;
- int ndim = scm_ilength (args);
- SCM_ASSERT (0 <= ndim, args, s_bad_spec, what);
- ra = scm_make_ra (ndim);
- SCM_ARRAY_BASE (ra) = 0;
- s = SCM_ARRAY_DIMS (ra);
- for (; SCM_NIMP (args); s++, args = SCM_CDR (args))
- {
- spec = SCM_CAR (args);
- if (SCM_IMP (spec))
-
- {
- SCM_ASSERT (SCM_INUMP (spec) && SCM_INUM (spec) >= 0, spec, s_bad_spec, what);
- s->lbnd = 0;
- s->ubnd = SCM_INUM (spec) - 1;
- s->inc = 1;
- }
- else
- {
- SCM_ASSERT (SCM_CONSP (spec) && SCM_INUMP (SCM_CAR (spec)), spec, s_bad_spec, what);
- s->lbnd = SCM_INUM (SCM_CAR (spec));
- sp = SCM_CDR (spec);
- SCM_ASSERT (SCM_INUMP (SCM_CAR (sp)) && SCM_NULLP (SCM_CDR (sp)),
- spec, s_bad_spec, what);
- s->ubnd = SCM_INUM (SCM_CAR (sp));
- s->inc = 1;
- }
- }
- return ra;
-}
-
-SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 0, 1, scm_dimensions_to_uniform_array);
-
-SCM
-scm_dimensions_to_uniform_array (dims, prot, fill)
- SCM dims;
- SCM prot;
- SCM fill;
-{
- scm_sizet k, vlen = 1;
- long rlen = 1;
- scm_array_dim *s;
- SCM ra;
- if (SCM_INUMP (dims))
- if (SCM_INUM (dims) < SCM_LENGTH_MAX)
- {
- SCM answer;
- answer = scm_make_uve (SCM_INUM (dims), prot);
- if (SCM_NNULLP (fill))
- {
- SCM_ASSERT (1 == scm_ilength (fill),
- scm_makfrom0str (s_dimensions_to_uniform_array),
- SCM_WNA, NULL);
- scm_array_fill_x (answer, SCM_CAR (fill));
- }
- else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
- scm_array_fill_x (answer, SCM_MAKINUM (0));
- else
- scm_array_fill_x (answer, prot);
- return answer;
- }
- else
- dims = scm_cons (dims, SCM_EOL);
- SCM_ASSERT (SCM_NULLP (dims) || (SCM_NIMP (dims) && SCM_CONSP (dims)),
- dims, SCM_ARG1, s_dimensions_to_uniform_array);
- ra = scm_shap2ra (dims, s_dimensions_to_uniform_array);
- SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS);
- s = SCM_ARRAY_DIMS (ra);
- k = SCM_ARRAY_NDIM (ra);
- while (k--)
- {
- s[k].inc = (rlen > 0 ? rlen : 0);
- rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
- vlen *= (s[k].ubnd - s[k].lbnd + 1);
- }
- if (rlen < SCM_LENGTH_MAX)
- SCM_ARRAY_V (ra) = scm_make_uve ((rlen > 0 ? rlen : 0L), prot);
- else
- {
- scm_sizet bit;
- switch (SCM_TYP7 (scm_make_uve (0L, prot)))
- {
- default:
- bit = SCM_LONG_BIT;
- break;
- case scm_tc7_bvect:
- bit = 1;
- break;
- case scm_tc7_string:
- bit = SCM_CHAR_BIT;
- break;
- case scm_tc7_fvect:
- bit = sizeof (float) * SCM_CHAR_BIT / sizeof (char);
- break;
- case scm_tc7_dvect:
- bit = sizeof (double) * SCM_CHAR_BIT / sizeof (char);
- break;
- case scm_tc7_cvect:
- bit = 2 * sizeof (double) * SCM_CHAR_BIT / sizeof (char);
- break;
- }
- SCM_ARRAY_BASE (ra) = (SCM_LONG_BIT + bit - 1) / bit;
- rlen += SCM_ARRAY_BASE (ra);
- SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot);
- *((long *) SCM_VELTS (SCM_ARRAY_V (ra))) = rlen;
- }
- if (SCM_NNULLP (fill))
- {
- SCM_ASSERT (1 == scm_ilength (fill),
- scm_makfrom0str (s_dimensions_to_uniform_array), SCM_WNA,
- NULL);
- scm_array_fill_x (ra, SCM_CAR (fill));
- }
- else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
- scm_array_fill_x (ra, SCM_MAKINUM (0));
- else
- scm_array_fill_x (ra, prot);
- if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
- return SCM_ARRAY_V (ra);
- return ra;
-}
-
-
-void
-scm_ra_set_contp (ra)
- SCM ra;
-{
- scm_sizet k = SCM_ARRAY_NDIM (ra);
- if (k)
- {
- long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
- while (k--)
- {
- if (inc != SCM_ARRAY_DIMS (ra)[k].inc)
- {
- SCM_SETAND_CAR (ra, ~SCM_ARRAY_CONTIGUOUS);
- return;
- }
- inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd
- - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
- }
- }
- SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS);
-}
-
-
-SCM_PROC(s_make_shared_array, "make-shared-array", 2, 0, 1, scm_make_shared_array);
-
-SCM
-scm_make_shared_array (oldra, mapfunc, dims)
- SCM oldra;
- SCM mapfunc;
- SCM dims;
-{
- SCM ra;
- SCM inds, indptr;
- SCM imap;
- scm_sizet i, k;
- long old_min, new_min, old_max, new_max;
- scm_array_dim *s;
- SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (mapfunc), mapfunc, SCM_ARG2, s_make_shared_array);
- SCM_ASSERT (SCM_NIMP (oldra) && (SCM_BOOL_F != scm_array_p (oldra, SCM_UNDEFINED)), oldra, SCM_ARG1, s_make_shared_array);
- ra = scm_shap2ra (dims, s_make_shared_array);
- if (SCM_ARRAYP (oldra))
- {
- SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra);
- old_min = old_max = SCM_ARRAY_BASE (oldra);
- s = SCM_ARRAY_DIMS (oldra);
- k = SCM_ARRAY_NDIM (oldra);
- while (k--)
- {
- if (s[k].inc > 0)
- old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
- else
- old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
- }
- }
- else
- {
- SCM_ARRAY_V (ra) = oldra;
- old_min = 0;
- old_max = (long) SCM_LENGTH (oldra) - 1;
- }
- inds = SCM_EOL;
- s = SCM_ARRAY_DIMS (ra);
- for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
- {
- inds = scm_cons (SCM_MAKINUM (s[k].lbnd), inds);
- if (s[k].ubnd < s[k].lbnd)
- {
- if (1 == SCM_ARRAY_NDIM (ra))
- ra = scm_make_uve (0L, scm_array_prototype (ra));
- else
- SCM_ARRAY_V (ra) = scm_make_uve (0L, scm_array_prototype (ra));
- return ra;
- }
- }
- imap = scm_apply (mapfunc, scm_list_reverse (inds), SCM_EOL);
- if (SCM_ARRAYP (oldra))
- i = (scm_sizet) scm_aind (oldra, imap, s_make_shared_array);
- else
- {
- if (SCM_NINUMP (imap))
-
- {
- SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)),
- imap, s_bad_ind, s_make_shared_array);
- imap = SCM_CAR (imap);
- }
- i = SCM_INUM (imap);
- }
- SCM_ARRAY_BASE (ra) = new_min = new_max = i;
- indptr = inds;
- k = SCM_ARRAY_NDIM (ra);
- while (k--)
- {
- if (s[k].ubnd > s[k].lbnd)
- {
- SCM_SETCAR (indptr, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1));
- imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
- if (SCM_ARRAYP (oldra))
-
- s[k].inc = scm_aind (oldra, imap, s_make_shared_array) - i;
- else
- {
- if (SCM_NINUMP (imap))
-
- {
- SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)),
- imap, s_bad_ind, s_make_shared_array);
- imap = SCM_CAR (imap);
- }
- s[k].inc = (long) SCM_INUM (imap) - i;
- }
- i += s[k].inc;
- if (s[k].inc > 0)
- new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
- else
- new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
- }
- else
- s[k].inc = new_max - new_min + 1; /* contiguous by default */
- indptr = SCM_CDR (indptr);
- }
- SCM_ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED,
- "mapping out of range", s_make_shared_array);
- if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
- {
- if (1 == s->inc && 0 == s->lbnd
- && SCM_LENGTH (SCM_ARRAY_V (ra)) == 1 + s->ubnd)
- return SCM_ARRAY_V (ra);
- if (s->ubnd < s->lbnd)
- return scm_make_uve (0L, scm_array_prototype (ra));
- }
- scm_ra_set_contp (ra);
- return ra;
-}
-
-
-/* args are RA . DIMS */
-SCM_PROC(s_transpose_array, "transpose-array", 0, 0, 1, scm_transpose_array);
-
-SCM
-scm_transpose_array (args)
- SCM args;
-{
- SCM ra, res, vargs, *ve = &vargs;
- scm_array_dim *s, *r;
- int ndim, i, k;
- SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (s_transpose_array),
- SCM_WNA, NULL);
- ra = SCM_CAR (args);
- SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_transpose_array);
- args = SCM_CDR (args);
- switch (SCM_TYP7 (ra))
- {
- default:
- badarg:scm_wta (ra, (char *) SCM_ARGn, s_transpose_array);
- case scm_tc7_bvect:
- case scm_tc7_string:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_svect:
-#ifdef LONGLONGS
- case scm_tc7_llvect:
-#endif
- SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)),
- scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
- SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2,
- s_transpose_array);
- SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE,
- s_transpose_array);
- return ra;
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
- vargs = scm_vector (args);
- SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra),
- scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
- ve = SCM_VELTS (vargs);
- ndim = 0;
- for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
- {
- i = SCM_INUM (ve[k]);
- SCM_ASSERT (SCM_INUMP (ve[k]) && i >= 0 && i < SCM_ARRAY_NDIM (ra),
- ve[k], SCM_ARG2, s_transpose_array);
- if (ndim < i)
- ndim = i;
- }
- ndim++;
- res = scm_make_ra (ndim);
- SCM_ARRAY_V (res) = SCM_ARRAY_V (ra);
- SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra);
- for (k = ndim; k--;)
- {
- SCM_ARRAY_DIMS (res)[k].lbnd = 0;
- SCM_ARRAY_DIMS (res)[k].ubnd = -1;
- }
- for (k = SCM_ARRAY_NDIM (ra); k--;)
- {
- i = SCM_INUM (ve[k]);
- s = &(SCM_ARRAY_DIMS (ra)[k]);
- r = &(SCM_ARRAY_DIMS (res)[i]);
- if (r->ubnd < r->lbnd)
- {
- r->lbnd = s->lbnd;
- r->ubnd = s->ubnd;
- r->inc = s->inc;
- ndim--;
- }
- else
- {
- if (r->ubnd > s->ubnd)
- r->ubnd = s->ubnd;
- if (r->lbnd < s->lbnd)
- {
- SCM_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
- r->lbnd = s->lbnd;
- }
- r->inc += s->inc;
- }
- }
- SCM_ASSERT (ndim <= 0, args, "bad argument scm_list", s_transpose_array);
- scm_ra_set_contp (res);
- return res;
- }
-}
-
-/* args are RA . AXES */
-SCM_PROC(s_enclose_array, "enclose-array", 0, 0, 1, scm_enclose_array);
-
-SCM
-scm_enclose_array (axes)
- SCM axes;
-{
- SCM axv, ra, res, ra_inr;
- scm_array_dim vdim, *s = &vdim;
- int ndim, j, k, ninr, noutr;
- SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (s_enclose_array), SCM_WNA,
- NULL);
- ra = SCM_CAR (axes);
- axes = SCM_CDR (axes);
- if (SCM_NULLP (axes))
-
- axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
- ninr = scm_ilength (axes);
- ra_inr = scm_make_ra (ninr);
- SCM_ASRTGO (SCM_NIMP (ra), badarg1);
- switch SCM_TYP7
- (ra)
- {
- default:
- badarg1:scm_wta (ra, (char *) SCM_ARG1, s_enclose_array);
- case scm_tc7_string:
- case scm_tc7_bvect:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_vector:
- case scm_tc7_svect:
-#ifdef LONGLONGS
- case scm_tc7_llvect:
-#endif
- s->lbnd = 0;
- s->ubnd = SCM_LENGTH (ra) - 1;
- s->inc = 1;
- SCM_ARRAY_V (ra_inr) = ra;
- SCM_ARRAY_BASE (ra_inr) = 0;
- ndim = 1;
- break;
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (ra), badarg1);
- s = SCM_ARRAY_DIMS (ra);
- SCM_ARRAY_V (ra_inr) = SCM_ARRAY_V (ra);
- SCM_ARRAY_BASE (ra_inr) = SCM_ARRAY_BASE (ra);
- ndim = SCM_ARRAY_NDIM (ra);
- break;
- }
- noutr = ndim - ninr;
- axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0));
- SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (s_enclose_array),
- SCM_WNA, NULL);
- res = scm_make_ra (noutr);
- SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
- SCM_ARRAY_V (res) = ra_inr;
- for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
- {
- SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", s_enclose_array);
- j = SCM_INUM (SCM_CAR (axes));
- SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
- SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
- SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
- SCM_CHARS (axv)[j] = 1;
- }
- for (j = 0, k = 0; k < noutr; k++, j++)
- {
- while (SCM_CHARS (axv)[j])
- j++;
- SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
- SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
- SCM_ARRAY_DIMS (res)[k].inc = s[j].inc;
- }
- scm_ra_set_contp (ra_inr);
- scm_ra_set_contp (res);
- return res;
-}
-
-
-
-SCM_PROC(s_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, scm_array_in_bounds_p);
-
-SCM
-scm_array_in_bounds_p (args)
- SCM args;
-{
- SCM v, ind = SCM_EOL;
- long pos = 0;
- register scm_sizet k;
- register long j;
- scm_array_dim *s;
- SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_array_in_bounds_p),
- SCM_WNA, NULL);
- v = SCM_CAR (args);
- args = SCM_CDR (args);
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- if (SCM_NIMP (args))
-
- {
- ind = SCM_CAR (args);
- args = SCM_CDR (args);
- SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, s_array_in_bounds_p);
- pos = SCM_INUM (ind);
- }
-tail:
- switch SCM_TYP7
- (v)
- {
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p);
- wna: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p));
- case scm_tc7_smob:
- k = SCM_ARRAY_NDIM (v);
- s = SCM_ARRAY_DIMS (v);
- pos = SCM_ARRAY_BASE (v);
- if (!k)
- {
- SCM_ASRTGO (SCM_NULLP (ind), wna);
- ind = SCM_INUM0;
- }
- else
- while (!0)
- {
- j = SCM_INUM (ind);
- if (!(j >= (s->lbnd) && j <= (s->ubnd)))
- {
- SCM_ASRTGO (--k == scm_ilength (args), wna);
- return SCM_BOOL_F;
- }
- pos += (j - s->lbnd) * (s->inc);
- if (!(--k && SCM_NIMP (args)))
- break;
- ind = SCM_CAR (args);
- args = SCM_CDR (args);
- s++;
- SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, s_array_in_bounds_p);
- }
- SCM_ASRTGO (0 == k, wna);
- v = SCM_ARRAY_V (v);
- goto tail;
- case scm_tc7_bvect:
- case scm_tc7_string:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_svect:
-#ifdef LONGLONGS
- case scm_tc7_llvect:
-#endif
- case scm_tc7_vector:
- SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna);
- return pos >= 0 && pos < SCM_LENGTH (v) ? SCM_BOOL_T : SCM_BOOL_F;
- }
-}
-
-
-SCM_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref);
-SCM_PROC(s_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, scm_uniform_vector_ref);
-
-SCM
-scm_uniform_vector_ref (v, args)
- SCM v;
- SCM args;
-{
- long pos;
-
- if (SCM_IMP (v))
- {
- SCM_ASRTGO (SCM_NULLP (args), badarg);
- return v;
- }
- else if (SCM_ARRAYP (v))
- {
- pos = scm_aind (v, args, s_uniform_vector_ref);
- v = SCM_ARRAY_V (v);
- }
- else
- {
- if (SCM_NIMP (args))
-
- {
- SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_uniform_vector_ref);
- pos = SCM_INUM (SCM_CAR (args));
- SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
- }
- else
- {
- SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_uniform_vector_ref);
- pos = SCM_INUM (args);
- }
- SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng);
- }
- switch SCM_TYP7
- (v)
- {
- default:
- if (SCM_NULLP (args))
- return v;
- badarg:
- scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref);
- abort ();
- outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos));
- wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref));
- case scm_tc7_smob:
- { /* enclosed */
- int k = SCM_ARRAY_NDIM (v);
- SCM res = scm_make_ra (k);
- SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
- SCM_ARRAY_BASE (res) = pos;
- while (k--)
- {
- SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
- SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
- SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
- }
- return res;
- }
- case scm_tc7_bvect:
- if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT)))
- return SCM_BOOL_T;
- else
- return SCM_BOOL_F;
- case scm_tc7_string:
- return SCM_MAKICHR (SCM_CHARS (v)[pos]);
- case scm_tc7_byvect:
- return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]);
-# ifdef SCM_INUMS_ONLY
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- return SCM_MAKINUM (SCM_VELTS (v)[pos]);
-# else
- case scm_tc7_uvect:
- return scm_ulong2num(SCM_VELTS(v)[pos]);
- case scm_tc7_ivect:
- return scm_long2num(SCM_VELTS(v)[pos]);
-# endif
-
- case scm_tc7_svect:
- return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
-#endif
-
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- return scm_makflo (((float *) SCM_CDR (v))[pos]);
-#endif
- case scm_tc7_dvect:
- return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0);
- case scm_tc7_cvect:
- return scm_makdbl (((double *) SCM_CDR (v))[2 * pos],
- ((double *) SCM_CDR (v))[2 * pos + 1]);
-#endif
- case scm_tc7_vector:
- return SCM_VELTS (v)[pos];
- }
-}
-
-/* Internal version of scm_uniform_vector_ref for uves that does no error checking and
- tries to recycle conses. (Make *sure* you want them recycled.) */
-
-SCM
-scm_cvref (v, pos, last)
- SCM v;
- scm_sizet pos;
- SCM last;
-{
- switch SCM_TYP7
- (v)
- {
- default:
- scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref");
- case scm_tc7_bvect:
- if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT)))
- return SCM_BOOL_T;
- else
- return SCM_BOOL_F;
- case scm_tc7_string:
- return SCM_MAKICHR (SCM_CHARS (v)[pos]);
- case scm_tc7_byvect:
- return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]);
-# ifdef SCM_INUMS_ONLY
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- return SCM_MAKINUM (SCM_VELTS (v)[pos]);
-# else
- case scm_tc7_uvect:
- return scm_ulong2num(SCM_VELTS(v)[pos]);
- case scm_tc7_ivect:
- return scm_long2num(SCM_VELTS(v)[pos]);
-# endif
- case scm_tc7_svect:
- return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
-#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CAR (last)))
- {
- SCM_FLO (last) = ((float *) SCM_CDR (v))[pos];
- return last;
- }
- return scm_makflo (((float *) SCM_CDR (v))[pos]);
-#endif
- case scm_tc7_dvect:
-#ifdef SCM_SINGLES
- if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last))
-#else
- if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last)))
-#endif
- {
- SCM_REAL (last) = ((double *) SCM_CDR (v))[pos];
- return last;
- }
- return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0);
- case scm_tc7_cvect:
- if (SCM_NIMP (last) && scm_tc_dblc == SCM_CAR (last))
- {
- SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos];
- SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1];
- return last;
- }
- return scm_makdbl (((double *) SCM_CDR (v))[2 * pos],
- ((double *) SCM_CDR (v))[2 * pos + 1]);
-#endif
- case scm_tc7_vector:
- return SCM_VELTS (v)[pos];
- case scm_tc7_smob:
- { /* enclosed scm_array */
- int k = SCM_ARRAY_NDIM (v);
- SCM res = scm_make_ra (k);
- SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
- SCM_ARRAY_BASE (res) = pos;
- while (k--)
- {
- SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
- SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
- SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
- }
- return res;
- }
- }
-}
-
-SCM_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);
-SCM_PROC(s_array_set_x, "array-set!", 2, 0, 1, scm_array_set_x);
-
-SCM
-scm_array_set_x (v, obj, args)
- SCM v;
- SCM obj;
- SCM args;
-{
- long pos;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- if (SCM_ARRAYP (v))
- {
- pos = scm_aind (v, args, s_array_set_x);
- v = SCM_ARRAY_V (v);
- }
- else
- {
- if (SCM_NIMP (args))
- {
- SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_array_set_x);
- pos = SCM_INUM (SCM_CAR (args));
- SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
- }
- else
- {
- SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_array_set_x);
- pos = SCM_INUM (args);
- }
- SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng);
- }
- switch (SCM_TYP7 (v))
- {
- default: badarg1:
- scm_wta (v, (char *) SCM_ARG1, s_array_set_x);
- abort ();
- outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos));
- wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x));
- case scm_tc7_smob: /* enclosed */
- goto badarg1;
- case scm_tc7_bvect:
- if (SCM_BOOL_F == obj)
- SCM_VELTS (v)[pos / SCM_LONG_BIT] &= ~(1L << (pos % SCM_LONG_BIT));
- else if (SCM_BOOL_T == obj)
- SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT));
- else
- badarg3:scm_wta (obj, (char *) SCM_ARG3, s_array_set_x);
- break;
- case scm_tc7_string:
- SCM_ASRTGO (SCM_ICHRP (obj), badarg3);
- SCM_CHARS (v)[pos] = SCM_ICHR (obj);
- break;
- case scm_tc7_byvect:
- if (SCM_ICHRP (obj))
- obj = SCM_MAKINUM (SCM_ICHR (obj));
- SCM_ASRTGO (SCM_INUMP (obj), badarg3);
- ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj);
- break;
-# ifdef SCM_INUMS_ONLY
- case scm_tc7_uvect:
- SCM_ASRTGO (SCM_INUM (obj) >= 0, badarg3);
- case scm_tc7_ivect:
- SCM_ASRTGO(SCM_INUMP(obj), badarg3); SCM_VELTS(v)[pos] = SCM_INUM(obj); break;
-# else
- case scm_tc7_uvect:
- SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG3, s_array_set_x); break;
- case scm_tc7_ivect:
- SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG3, s_array_set_x); break;
-# endif
- break;
-
- case scm_tc7_svect:
- SCM_ASRTGO (SCM_INUMP (obj), badarg3);
- ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj);
- break;
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG3, s_array_set_x);
- break;
-#endif
-
-
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3);
- ((float *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
- break;
-#endif
- case scm_tc7_dvect:
- SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3);
- ((double *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
- break;
- case scm_tc7_cvect:
- SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badarg3);
- ((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj);
- ((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0;
- break;
-#endif
- case scm_tc7_vector:
- SCM_VELTS (v)[pos] = obj;
- break;
- }
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents);
-
-SCM
-scm_array_contents (ra, strict)
- SCM ra;
- SCM strict;
-{
- SCM sra;
- if (SCM_IMP (ra))
- return SCM_BOOL_F;
- switch SCM_TYP7
- (ra)
- {
- default:
- return SCM_BOOL_F;
- case scm_tc7_vector:
- case scm_tc7_string:
- case scm_tc7_bvect:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_svect:
-#ifdef LONGLONGS
- case scm_tc7_llvect:
-#endif
- return ra;
- case scm_tc7_smob:
- {
- scm_sizet k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
- if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
- return SCM_BOOL_F;
- for (k = 0; k < ndim; k++)
- len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
- if (!SCM_UNBNDP (strict))
- {
- if SCM_ARRAY_BASE
- (ra) return SCM_BOOL_F;
- if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc))
- return SCM_BOOL_F;
- if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
- {
- if (len != SCM_LENGTH (SCM_ARRAY_V (ra)) ||
- SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
- len % SCM_LONG_BIT)
- return SCM_BOOL_F;
- }
- }
- if ((len == SCM_LENGTH (SCM_ARRAY_V (ra))) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
- return SCM_ARRAY_V (ra);
- sra = scm_make_ra (1);
- SCM_ARRAY_DIMS (sra)->lbnd = 0;
- SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
- SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra);
- SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra);
- SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
- return sra;
- }
- }
-}
-
-
-SCM
-scm_ra2contig (ra, copy)
- SCM ra;
- int copy;
-{
- SCM ret;
- long inc = 1;
- scm_sizet k, len = 1;
- for (k = SCM_ARRAY_NDIM (ra); k--;)
- len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
- k = SCM_ARRAY_NDIM (ra);
- if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
- {
- if (scm_tc7_bvect != SCM_TYP7 (ra))
- return ra;
- if ((len == SCM_LENGTH (SCM_ARRAY_V (ra)) &&
- 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
- 0 == len % SCM_LONG_BIT))
- return ra;
- }
- ret = scm_make_ra (k);
- SCM_ARRAY_BASE (ret) = 0;
- while (k--)
- {
- SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd;
- SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd;
- SCM_ARRAY_DIMS (ret)[k].inc = inc;
- inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
- }
- SCM_ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prototype (ra));
- if (copy)
- scm_array_copy_x (ra, ret);
- return ret;
-}
-
-
-
-SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 1, 0, scm_uniform_array_read_x);
-
-SCM
-scm_uniform_array_read_x (ra, port)
- SCM ra;
- SCM port;
-{
- SCM cra = SCM_UNDEFINED, v = ra;
- long sz, len, ans;
- long start = 0;
-
- if (SCM_UNBNDP (port))
- port = scm_cur_inp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPINFPORTP (port), port, SCM_ARG2,
- s_uniform_array_read_x);
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
-
- len = SCM_LENGTH (v);
-loop:
- switch SCM_TYP7 (v)
- {
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x);
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
- cra = scm_ra2contig (ra, 0);
- start = SCM_ARRAY_BASE (cra);
- len = SCM_ARRAY_DIMS (cra)->inc *
- (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
- v = SCM_ARRAY_V (cra);
- goto loop;
- case scm_tc7_string:
- case scm_tc7_byvect:
- sz = sizeof (char);
- break;
- case scm_tc7_bvect:
- len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
- start /= SCM_LONG_BIT;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- sz = sizeof (long);
- break;
- case scm_tc7_svect:
- sz = sizeof (short);
- break;
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- sz = sizeof (long_long);
- break;
-#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- sz = sizeof (float);
- break;
-#endif
- case scm_tc7_dvect:
- sz = sizeof (double);
- break;
- case scm_tc7_cvect:
- sz = 2 * sizeof (double);
- break;
-#endif
- }
-
- /* An ungetc before an fread will not work on some systems if setbuf(0).
- do #define NOSETBUF in scmfig.h to fix this. */
- if (SCM_CRDYP (port))
- { /* UGGH!!! */
- ungetc (SCM_CGETUN (port), (FILE *)SCM_STREAM (port));
- SCM_CLRDY (port); /* Clear ungetted char */
- }
-
- SCM_SYSCALL (ans = fread (SCM_CHARS (v) + start * sz,
- (scm_sizet) sz, (scm_sizet) len,
- (FILE *)SCM_STREAM (port)));
-
- if (SCM_TYP7 (v) == scm_tc7_bvect)
- ans *= SCM_LONG_BIT;
-
- if (v != ra && cra != ra)
- scm_array_copy_x (cra, ra);
-
- return SCM_MAKINUM (ans);
-}
-
-SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 1, 0, scm_uniform_array_write);
-
-SCM
-scm_uniform_array_write (v, port)
- SCM v;
- SCM port;
-{
- long sz, len, ans;
- long start = 0;
- if (SCM_UNBNDP (port))
- port = scm_cur_outp;
- else
- SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTFPORTP (port), port, SCM_ARG2, s_uniform_array_write);
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- len = SCM_LENGTH (v);
-loop:
- switch SCM_TYP7
- (v)
- {
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write);
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
- v = scm_ra2contig (v, 1);
- start = SCM_ARRAY_BASE (v);
- len = SCM_ARRAY_DIMS (v)->inc * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1);
- v = SCM_ARRAY_V (v);
- goto loop;
- case scm_tc7_byvect:
- case scm_tc7_string:
- sz = sizeof (char);
- break;
- case scm_tc7_bvect:
- len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
- start /= SCM_LONG_BIT;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- sz = sizeof (long);
- break;
- case scm_tc7_svect:
- sz = sizeof (short);
- break;
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- sz = sizeof (long_long);
- break;
-#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- sz = sizeof (float);
- break;
-#endif
- case scm_tc7_dvect:
- sz = sizeof (double);
- break;
- case scm_tc7_cvect:
- sz = 2 * sizeof (double);
- break;
-#endif
- }
- SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port)));
- if (SCM_TYP7 (v) == scm_tc7_bvect)
- ans *= SCM_LONG_BIT;
- return SCM_MAKINUM (ans);
-}
-
-
-static char cnt_tab[16] =
-{0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
-
-SCM_PROC(s_bit_count, "bit-count", 2, 0, 0, scm_bit_count);
-
-SCM
-scm_bit_count (item, seq)
- SCM item;
- SCM seq;
-{
- long i;
- register unsigned long cnt = 0, w;
- SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count);
- switch SCM_TYP7
- (seq)
- {
- default:
- scm_wta (seq, (char *) SCM_ARG2, s_bit_count);
- case scm_tc7_bvect:
- if (0 == SCM_LENGTH (seq))
- return SCM_INUM0;
- i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT;
- w = SCM_VELTS (seq)[i];
- if (SCM_FALSEP (item))
- w = ~w;
- w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT);
- while (!0)
- {
- for (; w; w >>= 4)
- cnt += cnt_tab[w & 0x0f];
- if (0 == i--)
- return SCM_MAKINUM (cnt);
- w = SCM_VELTS (seq)[i];
- if (SCM_FALSEP (item))
- w = ~w;
- }
- }
-}
-
-
-SCM_PROC(s_bit_position, "bit-position", 3, 0, 0, scm_bit_position);
-
-SCM
-scm_bit_position (item, v, k)
- SCM item;
- SCM v;
- SCM k;
-{
- long i, lenw, xbits, pos = SCM_INUM (k);
- register unsigned long w;
- SCM_ASSERT (SCM_NIMP (v), v, SCM_ARG2, s_bit_position);
- SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG3, s_bit_position);
- SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0),
- k, SCM_OUTOFRANGE, s_bit_position);
- if (pos == SCM_LENGTH (v))
- return SCM_BOOL_F;
- switch SCM_TYP7
- (v)
- {
- default:
- scm_wta (v, (char *) SCM_ARG2, s_bit_position);
- case scm_tc7_bvect:
- if (0 == SCM_LENGTH (v))
- return SCM_MAKINUM (-1L);
- lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
- i = pos / SCM_LONG_BIT;
- w = SCM_VELTS (v)[i];
- if (SCM_FALSEP (item))
- w = ~w;
- xbits = (pos % SCM_LONG_BIT);
- pos -= xbits;
- w = ((w >> xbits) << xbits);
- xbits = SCM_LONG_BIT - 1 - (SCM_LENGTH (v) - 1) % SCM_LONG_BIT;
- while (!0)
- {
- if (w && (i == lenw))
- w = ((w << xbits) >> xbits);
- if (w)
- while (w)
- switch (w & 0x0f)
- {
- default:
- return SCM_MAKINUM (pos);
- case 2:
- case 6:
- case 10:
- case 14:
- return SCM_MAKINUM (pos + 1);
- case 4:
- case 12:
- return SCM_MAKINUM (pos + 2);
- case 8:
- return SCM_MAKINUM (pos + 3);
- case 0:
- pos += 4;
- w >>= 4;
- }
- if (++i > lenw)
- break;
- pos += SCM_LONG_BIT;
- w = SCM_VELTS (v)[i];
- if (SCM_FALSEP (item))
- w = ~w;
- }
- return SCM_BOOL_F;
- }
-}
-
-
-SCM_PROC(s_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_bit_set_star_x);
-
-SCM
-scm_bit_set_star_x (v, kv, obj)
- SCM v;
- SCM kv;
- SCM obj;
-{
- register long i, k, vlen;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- SCM_ASRTGO (SCM_NIMP (kv), badarg2);
- switch SCM_TYP7
- (kv)
- {
- default:
- badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x);
- case scm_tc7_uvect:
- switch SCM_TYP7
- (v)
- {
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x);
- case scm_tc7_bvect:
- vlen = SCM_LENGTH (v);
- if (SCM_BOOL_F == obj)
- for (i = SCM_LENGTH (kv); i;)
- {
- k = SCM_VELTS (kv)[--i];
- SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x);
- SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT));
- }
- else if (SCM_BOOL_T == obj)
- for (i = SCM_LENGTH (kv); i;)
- {
- k = SCM_VELTS (kv)[--i];
- SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x);
- SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT));
- }
- else
- badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_set_star_x);
- }
- break;
- case scm_tc7_bvect:
- SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1);
- if (SCM_BOOL_F == obj)
- for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_VELTS (v)[k] &= ~(SCM_VELTS (kv)[k]);
- else if (SCM_BOOL_T == obj)
- for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_VELTS (v)[k] |= SCM_VELTS (kv)[k];
- else
- goto badarg3;
- break;
- }
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_bit_count_star, "bit-count*", 3, 0, 0, scm_bit_count_star);
-
-SCM
-scm_bit_count_star (v, kv, obj)
- SCM v;
- SCM kv;
- SCM obj;
-{
- register long i, vlen, count = 0;
- register unsigned long k;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- SCM_ASRTGO (SCM_NIMP (kv), badarg2);
- switch SCM_TYP7
- (kv)
- {
- default:
- badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star);
- case scm_tc7_uvect:
- switch SCM_TYP7
- (v)
- {
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_count_star);
- case scm_tc7_bvect:
- vlen = SCM_LENGTH (v);
- if (SCM_BOOL_F == obj)
- for (i = SCM_LENGTH (kv); i;)
- {
- k = SCM_VELTS (kv)[--i];
- SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star);
- if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))))
- count++;
- }
- else if (SCM_BOOL_T == obj)
- for (i = SCM_LENGTH (kv); i;)
- {
- k = SCM_VELTS (kv)[--i];
- SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star);
- if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))
- count++;
- }
- else
- badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_count_star);
- }
- break;
- case scm_tc7_bvect:
- SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1);
- if (0 == SCM_LENGTH (v))
- return SCM_INUM0;
- SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3);
- obj = (SCM_BOOL_T == obj);
- i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT;
- k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]);
- k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT);
- while (!0)
- {
- for (; k; k >>= 4)
- count += cnt_tab[k & 0x0f];
- if (0 == i--)
- return SCM_MAKINUM (count);
- k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]);
- }
- }
- return SCM_MAKINUM (count);
-}
-
-
-SCM_PROC(s_bit_invert_x, "bit-invert!", 1, 0, 0, scm_bit_invert_x);
-
-SCM
-scm_bit_invert_x (v)
- SCM v;
-{
- register long k;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- k = SCM_LENGTH (v);
- switch SCM_TYP7
- (v)
- {
- case scm_tc7_bvect:
- for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k];
- break;
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_invert_x);
- }
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_string_upcase_x, "string-upcase!", 1, 0, 0, scm_string_upcase_x);
-
-SCM
-scm_string_upcase_x (v)
- SCM v;
-{
- register long k;
- register unsigned char *cs;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- k = SCM_LENGTH (v);
- switch SCM_TYP7
- (v)
- {
- case scm_tc7_string:
- cs = SCM_UCHARS (v);
- while (k--)
- cs[k] = scm_upcase(cs[k]);
- break;
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_upcase_x);
- }
- return v;
-}
-
-SCM_PROC(s_string_downcase_x, "string-downcase!", 1, 0, 0, scm_string_downcase_x);
-
-SCM
-scm_string_downcase_x (v)
- SCM v;
-{
- register long k;
- register unsigned char *cs;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- k = SCM_LENGTH (v);
- switch SCM_TYP7
- (v)
- {
- case scm_tc7_string:
- cs = SCM_UCHARS (v);
- while (k--)
- cs[k] = scm_downcase(cs[k]);
- break;
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_downcase_x);
- }
- return v;
-}
-
-
-
-SCM
-scm_istr2bve (str, len)
- char *str;
- long len;
-{
- SCM v = scm_make_uve (len, SCM_BOOL_T);
- long *data = (long *) SCM_VELTS (v);
- register unsigned long mask;
- register long k;
- register long j;
- for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++)
- {
- data[k] = 0L;
- j = len - k * SCM_LONG_BIT;
- if (j > SCM_LONG_BIT)
- j = SCM_LONG_BIT;
- for (mask = 1L; j--; mask <<= 1)
- switch (*str++)
- {
- case '0':
- break;
- case '1':
- data[k] |= mask;
- break;
- default:
- return SCM_BOOL_F;
- }
- }
- return v;
-}
-
-
-
-static SCM ra2l SCM_P ((SCM ra, scm_sizet base, scm_sizet k));
-
-static SCM
-ra2l (ra, base, k)
- SCM ra;
- scm_sizet base;
- scm_sizet k;
-{
- register SCM res = SCM_EOL;
- register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
- register scm_sizet i;
- if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
- return SCM_EOL;
- i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
- if (k < SCM_ARRAY_NDIM (ra) - 1)
- {
- do
- {
- i -= inc;
- res = scm_cons (ra2l (ra, i, k + 1), res);
- }
- while (i != base);
- }
- else
- do
- {
- i -= inc;
- res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_MAKINUM (i)), res);
- }
- while (i != base);
- return res;
-}
-
-
-SCM_PROC(s_array_to_list, "array->list", 1, 0, 0, scm_array_to_list);
-
-SCM
-scm_array_to_list (v)
- SCM v;
-{
- SCM res = SCM_EOL;
- register long k;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- switch SCM_TYP7
- (v)
- {
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_to_list);
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
- return ra2l (v, SCM_ARRAY_BASE (v), 0);
- case scm_tc7_vector:
- return scm_vector_to_list (v);
- case scm_tc7_string:
- return scm_string_to_list (v);
- case scm_tc7_bvect:
- {
- long *data = (long *) SCM_VELTS (v);
- register unsigned long mask;
- for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
- for (mask = 1L << (SCM_LONG_BIT - 1); mask; mask >>= 1)
- res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
- for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
- res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
- return res;
- }
-# ifdef SCM_INUMS_ONLY
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- {
- long *data = (long *) SCM_VELTS (v);
- for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (SCM_MAKINUM (data[k]), res);
- return res;
- }
-# else
- case scm_tc7_uvect: {
- long *data = (long *)SCM_VELTS(v);
- for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_ulong2num(data[k]), res);
- return res;
- }
- case scm_tc7_ivect: {
- long *data = (long *)SCM_VELTS(v);
- for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_long2num(data[k]), res);
- return res;
- }
-# endif
- case scm_tc7_svect: {
- short *data;
- data = (short *)SCM_VELTS(v);
- for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(SCM_MAKINUM (data[k]), res);
- return res;
- }
-#ifdef LONGLONGS
- case scm_tc7_llvect: {
- long_long *data;
- data = (long_long *)SCM_VELTS(v);
- for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_long_long2num(data[k]), res);
- return res;
- }
-#endif
-
-
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *data = (float *) SCM_VELTS (v);
- for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_makflo (data[k]), res);
- return res;
- }
-#endif /*SCM_SINGLES*/
- case scm_tc7_dvect:
- {
- double *data = (double *) SCM_VELTS (v);
- for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_makdbl (data[k], 0.0), res);
- return res;
- }
- case scm_tc7_cvect:
- {
- double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
- for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res);
- return res;
- }
-#endif /*SCM_FLOATS*/
- }
-}
-
-
-static char s_bad_ralst[] = "Bad scm_array contents scm_list";
-
-static int l2ra SCM_P ((SCM lst, SCM ra, scm_sizet base, scm_sizet k));
-
-SCM_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array);
-
-SCM
-scm_list_to_uniform_array (ndim, prot, lst)
- SCM ndim;
- SCM prot;
- SCM lst;
-{
- SCM shp = SCM_EOL;
- SCM row = lst;
- SCM ra;
- scm_sizet k;
- long n;
- SCM_ASSERT (SCM_INUMP (ndim), ndim, SCM_ARG1, s_list_to_uniform_array);
- k = SCM_INUM (ndim);
- while (k--)
- {
- n = scm_ilength (row);
- SCM_ASSERT (n >= 0, lst, SCM_ARG2, s_list_to_uniform_array);
- shp = scm_cons (SCM_MAKINUM (n), shp);
- if (SCM_NIMP (row))
- row = SCM_CAR (row);
- }
- ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot, SCM_EOL);
- if (SCM_NULLP (shp))
-
- {
- SCM_ASRTGO (1 == scm_ilength (lst), badlst);
- scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
- return ra;
- }
- if (!SCM_ARRAYP (ra))
- {
- for (k = 0; k < SCM_LENGTH (ra); k++, lst = SCM_CDR (lst))
- scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k));
- return ra;
- }
- if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0))
- return ra;
- else
- badlst:scm_wta (lst, s_bad_ralst, s_list_to_uniform_array);
- return SCM_BOOL_F;
-}
-
-static int
-l2ra (lst, ra, base, k)
- SCM lst;
- SCM ra;
- scm_sizet base;
- scm_sizet k;
-{
- register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
- register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
- int ok = 1;
- if (n <= 0)
- return (SCM_EOL == lst);
- if (k < SCM_ARRAY_NDIM (ra) - 1)
- {
- while (n--)
- {
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return 0;
- ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1);
- base += inc;
- lst = SCM_CDR (lst);
- }
- if (SCM_NNULLP (lst))
- return 0;
- }
- else
- {
- while (n--)
- {
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
- return 0;
- ok = ok && scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base));
- base += inc;
- lst = SCM_CDR (lst);
- }
- if (SCM_NNULLP (lst))
- return 0;
- }
- return ok;
-}
-
-
-static void rapr1 SCM_P ((SCM ra, scm_sizet j, scm_sizet k, SCM port, scm_print_state *pstate));
-
-static void
-rapr1 (ra, j, k, port, pstate)
- SCM ra;
- scm_sizet j;
- scm_sizet k;
- SCM port;
- scm_print_state *pstate;
-{
- long inc = 1;
- long n = SCM_LENGTH (ra);
- int enclosed = 0;
-tail:
- switch SCM_TYP7
- (ra)
- {
- case scm_tc7_smob:
- if (enclosed++)
- {
- SCM_ARRAY_BASE (ra) = j;
- if (n-- > 0)
- scm_iprin1 (ra, port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_gen_putc (' ', port);
- SCM_ARRAY_BASE (ra) = j;
- scm_iprin1 (ra, port, pstate);
- }
- break;
- }
- if (k + 1 < SCM_ARRAY_NDIM (ra))
- {
- long i;
- inc = SCM_ARRAY_DIMS (ra)[k].inc;
- for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
- {
- scm_gen_putc ('(', port);
- rapr1 (ra, j, k + 1, port, pstate);
- scm_gen_puts (scm_regular_string, ") ", port);
- j += inc;
- }
- if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
- { /* could be zero size. */
- scm_gen_putc ('(', port);
- rapr1 (ra, j, k + 1, port, pstate);
- scm_gen_putc (')', port);
- }
- break;
- }
- if SCM_ARRAY_NDIM
- (ra)
- { /* Could be zero-dimensional */
- inc = SCM_ARRAY_DIMS (ra)[k].inc;
- n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
- }
- else
- n = 1;
- ra = SCM_ARRAY_V (ra);
- goto tail;
- default:
- if (n-- > 0)
- scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_gen_putc (' ', port);
- scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
- }
- break;
- case scm_tc7_string:
- if (n-- > 0)
- scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
- if (SCM_WRITINGP (pstate))
- for (j += inc; n-- > 0; j += inc)
- {
- scm_gen_putc (' ', port);
- scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
- }
- else
- for (j += inc; n-- > 0; j += inc)
- scm_gen_putc (SCM_CHARS (ra)[j], port);
- break;
- case scm_tc7_byvect:
- if (n-- > 0)
- scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_gen_putc (' ', port);
- scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
- }
- break;
-
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- if (n-- > 0)
- scm_intprint (SCM_VELTS (ra)[j], 10, port);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_gen_putc (' ', port);
- scm_intprint (SCM_VELTS (ra)[j], 10, port);
- }
- break;
-
- case scm_tc7_svect:
- if (n-- > 0)
- scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_gen_putc (' ', port);
- scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
- }
- break;
-
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- if (n-- > 0)
- {
- SCM z = scm_makflo (1.0);
- SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_gen_putc (' ', port);
- SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, pstate);
- }
- }
- break;
-#endif /*SCM_SINGLES*/
- case scm_tc7_dvect:
- if (n-- > 0)
- {
- SCM z = scm_makdbl (1.0 / 3.0, 0.0);
- SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_gen_putc (' ', port);
- SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, pstate);
- }
- }
- break;
- case scm_tc7_cvect:
- if (n-- > 0)
- {
- SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0);
- SCM_REAL (z) = SCM_REAL (cz) = (((double *) SCM_VELTS (ra))[2 * j]);
- SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
- scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
- for (j += inc; n-- > 0; j += inc)
- {
- scm_gen_putc (' ', port);
- SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
- SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
- scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
- }
- }
- break;
-#endif /*SCM_FLOATS*/
- }
-}
-
-
-
-int
-scm_raprin1 (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- SCM v = exp;
- scm_sizet base = 0;
- scm_gen_putc ('#', port);
-tail:
- switch SCM_TYP7
- (v)
- {
- case scm_tc7_smob:
- {
- long ndim = SCM_ARRAY_NDIM (v);
- base = SCM_ARRAY_BASE (v);
- v = SCM_ARRAY_V (v);
- if (SCM_ARRAYP (v))
-
- {
- scm_gen_puts (scm_regular_string, "<enclosed-array ", port);
- rapr1 (exp, base, 0, port, pstate);
- scm_gen_putc ('>', port);
- return 1;
- }
- else
- {
- scm_intprint (ndim, 10, port);
- goto tail;
- }
- }
- case scm_tc7_bvect:
- if (exp == v)
- { /* a uve, not an scm_array */
- register long i, j, w;
- scm_gen_putc ('*', port);
- for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++)
- {
- w = SCM_VELTS (exp)[i];
- for (j = SCM_LONG_BIT; j; j--)
- {
- scm_gen_putc (w & 1 ? '1' : '0', port);
- w >>= 1;
- }
- }
- j = SCM_LENGTH (exp) % SCM_LONG_BIT;
- if (j)
- {
- w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT];
- for (; j; j--)
- {
- scm_gen_putc (w & 1 ? '1' : '0', port);
- w >>= 1;
- }
- }
- return 1;
- }
- else
- scm_gen_putc ('b', port);
- break;
- case scm_tc7_string:
- scm_gen_putc ('a', port);
- break;
- case scm_tc7_byvect:
- scm_gen_puts (scm_regular_string, "bytes", port);
- break;
- case scm_tc7_uvect:
- scm_gen_putc ('u', port);
- break;
- case scm_tc7_ivect:
- scm_gen_putc ('e', port);
- break;
- case scm_tc7_svect:
- scm_gen_puts (scm_regular_string, "short", port);
- break;
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- scm_gen_puts (scm_regular_string, "long_long", port);
- break;
-#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- scm_gen_putc ('s', port);
- break;
-#endif /*SCM_SINGLES*/
- case scm_tc7_dvect:
- scm_gen_putc ('i', port);
- break;
- case scm_tc7_cvect:
- scm_gen_putc ('c', port);
- break;
-#endif /*SCM_FLOATS*/
- }
- scm_gen_putc ('(', port);
- rapr1 (exp, base, 0, port, pstate);
- scm_gen_putc (')', port);
- return 1;
-}
-
-SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype);
-
-SCM
-scm_array_prototype (ra)
- SCM ra;
-{
- int enclosed = 0;
- SCM_ASRTGO (SCM_NIMP (ra), badarg);
-loop:
- switch SCM_TYP7
- (ra)
- {
- default:
- badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_prototype);
- case scm_tc7_smob:
- SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
- if (enclosed++)
- return SCM_UNSPECIFIED;
- ra = SCM_ARRAY_V (ra);
- goto loop;
- case scm_tc7_vector:
- return SCM_EOL;
- case scm_tc7_bvect:
- return SCM_BOOL_T;
- case scm_tc7_string:
- return SCM_MAKICHR ('a');
- case scm_tc7_byvect:
- return SCM_MAKICHR ('\0');
- case scm_tc7_uvect:
- return SCM_MAKINUM (1L);
- case scm_tc7_ivect:
- return SCM_MAKINUM (-1L);
- case scm_tc7_svect:
- return SCM_CDR (scm_intern ("s", 1));
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- return SCM_CDR (scm_intern ("l", 1));
-#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- return scm_makflo (1.0);
-#endif
- case scm_tc7_dvect:
- return scm_makdbl (1.0 / 3.0, 0.0);
- case scm_tc7_cvect:
- return scm_makdbl (0.0, 1.0);
-#endif
- }
-}
-
-
-static SCM markra SCM_P ((SCM ptr));
-
-static SCM
-markra (ptr)
- SCM ptr;
-{
- if SCM_GC8MARKP
- (ptr) return SCM_BOOL_F;
- SCM_SETGC8MARK (ptr);
- return SCM_ARRAY_V (ptr);
-}
-
-
-static scm_sizet freera SCM_P ((SCM ptr));
-
-static scm_sizet
-freera (ptr)
- SCM ptr;
-{
- scm_must_free (SCM_CHARS (ptr));
- return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim);
-}
-
-static scm_smobfuns rasmob =
-{markra, freera, scm_raprin1, scm_array_equal_p};
-
-
-/* This must be done after scm_init_scl() */
-
-void
-scm_init_unif ()
-{
-#include "unif.x"
- scm_tc16_array = scm_newsmob (&rasmob);
- scm_add_feature ("array");
-}
-
-#else /* ARRAYS */
-
-
-int
-scm_raprin1 (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- return 0;
-}
-
-
-SCM
-scm_istr2bve (str, len)
- char *str;
- long len;
-{
- return SCM_BOOL_F;
-}
-
-void
-scm_init_unif ()
-{
- scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x);
-}
-
-#endif /* ARRAYS */
diff --git a/libguile/unif.h b/libguile/unif.h
deleted file mode 100644
index 45aef3fe2..000000000
--- a/libguile/unif.h
+++ /dev/null
@@ -1,114 +0,0 @@
-/* classes: h_files */
-
-#ifndef UNIFH
-#define UNIFH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-typedef struct scm_array
-{
- SCM v;
- scm_sizet base;
-} scm_array;
-
-typedef struct scm_array_dim
-{
- long lbnd;
- long ubnd;
- long inc;
-} scm_array_dim;
-
-
-extern long scm_tc16_array;
-#define SCM_ARRAYP(a) (scm_tc16_array==SCM_TYP16(a))
-#define SCM_ARRAY_V(a) (((scm_array *)SCM_CDR(a))->v)
-#define SCM_ARRAY_NDIM(x) ((scm_sizet)(SCM_CAR(x)>>17))
-#define SCM_ARRAY_CONTIGUOUS 0x10000
-#define SCM_ARRAY_CONTP(x) (SCM_ARRAY_CONTIGUOUS & (int)SCM_CAR(x))
-#define SCM_ARRAY_BASE(a) (((scm_array *)SCM_CDR(a))->base)
-#define SCM_ARRAY_DIMS(a) ((scm_array_dim *)(SCM_CHARS(a)+sizeof(scm_array)))
-
-#define SCM_HUGE_LENGTH(x) (SCM_LENGTH_MAX==SCM_LENGTH(x) ? *((long *)SCM_VELTS(x)) : SCM_LENGTH(x))
-
-
-
-extern SCM scm_vector_set_length_x SCM_P ((SCM vect, SCM len));
-extern SCM scm_makflo SCM_P ((float x));
-extern SCM scm_make_uve SCM_P ((long k, SCM prot));
-extern SCM scm_uniform_vector_length SCM_P ((SCM v));
-extern SCM scm_array_p SCM_P ((SCM v, SCM prot));
-extern SCM scm_array_rank SCM_P ((SCM ra));
-extern SCM scm_array_dimensions SCM_P ((SCM ra));
-extern long scm_aind SCM_P ((SCM ra, SCM args, char *what));
-extern SCM scm_make_ra SCM_P ((int ndim));
-extern SCM scm_shap2ra SCM_P ((SCM args, char *what));
-extern SCM scm_dimensions_to_uniform_array SCM_P ((SCM dims, SCM prot, SCM fill));
-extern void scm_ra_set_contp SCM_P ((SCM ra));
-extern SCM scm_make_shared_array SCM_P ((SCM oldra, SCM mapfunc, SCM dims));
-extern SCM scm_transpose_array SCM_P ((SCM args));
-extern SCM scm_enclose_array SCM_P ((SCM axes));
-extern SCM scm_array_in_bounds_p SCM_P ((SCM args));
-extern SCM scm_uniform_vector_ref SCM_P ((SCM v, SCM args));
-extern SCM scm_cvref SCM_P ((SCM v, scm_sizet pos, SCM last));
-extern SCM scm_array_set_x SCM_P ((SCM v, SCM obj, SCM args));
-extern SCM scm_array_contents SCM_P ((SCM ra, SCM strict));
-extern SCM scm_ra2contig SCM_P ((SCM ra, int copy));
-extern SCM scm_uniform_array_read_x SCM_P ((SCM ra, SCM port));
-extern SCM scm_uniform_array_write SCM_P ((SCM v, SCM port));
-extern SCM scm_bit_count SCM_P ((SCM item, SCM seq));
-extern SCM scm_bit_position SCM_P ((SCM item, SCM v, SCM k));
-extern SCM scm_bit_set_star_x SCM_P ((SCM v, SCM kv, SCM obj));
-extern SCM scm_bit_count_star SCM_P ((SCM v, SCM kv, SCM obj));
-extern SCM scm_bit_invert_x SCM_P ((SCM v));
-extern SCM scm_string_upcase_x SCM_P ((SCM v));
-extern SCM scm_string_downcase_x SCM_P ((SCM v));
-extern SCM scm_istr2bve SCM_P ((char *str, long len));
-extern SCM scm_array_to_list SCM_P ((SCM v));
-extern SCM scm_list_to_uniform_array SCM_P ((SCM ndim, SCM prot, SCM lst));
-extern int scm_raprin1 SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-extern SCM scm_array_prototype SCM_P ((SCM ra));
-extern void scm_init_unif SCM_P ((void));
-
-#endif /* UNIFH */
diff --git a/libguile/variable.c b/libguile/variable.c
deleted file mode 100644
index 692219c0a..000000000
--- a/libguile/variable.c
+++ /dev/null
@@ -1,249 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "genio.h"
-#include "smob.h"
-
-#include "variable.h"
-
-
-static scm_sizet free_var SCM_P ((SCM obj));
-
-static scm_sizet
-free_var (obj)
- SCM obj;
-{
- return 0;
-}
-
-
-
-static int prin_var SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-
-static int
-prin_var (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_gen_puts (scm_regular_string, "#<variable ", port);
- scm_intprint(exp, 16, port);
- {
- SCM val_cell;
- val_cell = SCM_CDR(exp);
- if (SCM_CAR (val_cell) != SCM_UNDEFINED)
- {
- scm_gen_puts (scm_regular_string, " name: ", port);
- scm_iprin1 (SCM_CAR (val_cell), port, pstate);
- }
- scm_gen_puts (scm_regular_string, " binding: ", port);
- scm_iprin1 (SCM_CDR (val_cell), port, pstate);
- }
- scm_gen_putc('>', port);
- return 1;
-}
-
-
-static SCM scm_markvar SCM_P ((SCM ptr));
-
-static SCM
-scm_markvar (ptr)
- SCM ptr;
-{
- if (SCM_GC8MARKP (ptr))
- return SCM_BOOL_F;
- SCM_SETGC8MARK (ptr);
- return SCM_CDR (ptr);
-}
-
-int scm_tc16_variable;
-static scm_smobfuns variable_smob = {scm_markvar, free_var, prin_var, 0};
-
-
-static SCM anonymous_variable_sym;
-
-
-static SCM make_vcell_variable SCM_P ((SCM vcell));
-
-static SCM
-make_vcell_variable (vcell)
- SCM vcell;
-{
- SCM answer;
- SCM_NEWCELL(answer);
- SCM_REDEFER_INTS;
- SCM_SETCAR (answer, scm_tc16_variable);
- SCM_SETCDR (answer, vcell);
- SCM_REALLOW_INTS;
- return answer;
-}
-
-SCM_PROC(s_make_variable, "make-variable", 1, 1, 0, scm_make_variable);
-
-SCM
-scm_make_variable (init, name_hint)
- SCM init;
- SCM name_hint;
-{
- SCM val_cell;
-
- if (name_hint == SCM_UNDEFINED)
- name_hint = anonymous_variable_sym;
-
- SCM_NEWCELL(val_cell);
- SCM_DEFER_INTS;
- SCM_SETCAR (val_cell, name_hint);
- SCM_SETCDR (val_cell, init);
- SCM_ALLOW_INTS;
- return make_vcell_variable (val_cell);
-}
-
-
-SCM_PROC(s_make_undefined_variable, "make-undefined-variable", 0, 1, 0, scm_make_undefined_variable);
-
-SCM
-scm_make_undefined_variable (name_hint)
- SCM name_hint;
-{
- SCM vcell;
-
- if (name_hint == SCM_UNDEFINED)
- name_hint = anonymous_variable_sym;
-
- SCM_NEWCELL (vcell);
- SCM_DEFER_INTS;
- SCM_SETCAR (vcell, name_hint);
- SCM_SETCDR (vcell, SCM_UNDEFINED);
- SCM_ALLOW_INTS;
- return make_vcell_variable (vcell);
-}
-
-
-SCM_PROC(s_variable_p, "variable?", 1, 0, 0, scm_variable_p);
-
-SCM
-scm_variable_p (obj)
- SCM obj;
-{
- return ( (SCM_NIMP(obj) && SCM_VARIABLEP (obj))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-SCM_PROC(s_variable_ref, "variable-ref", 1, 0, 0, scm_variable_ref);
-
-SCM
-scm_variable_ref (var)
- SCM var;
-{
- SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP(var), var, SCM_ARG1, s_variable_ref);
- return SCM_CDR (SCM_CDR (var));
-}
-
-
-
-SCM_PROC(s_variable_set_x, "variable-set!", 2, 0, 0, scm_variable_set_x);
-
-SCM
-scm_variable_set_x (var, val)
- SCM var;
- SCM val;
-{
- SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_set_x);
- SCM_SETCDR (SCM_CDR (var), val);
- return SCM_UNSPECIFIED;
-}
-
-
-SCM_PROC(s_builtin_variable, "builtin-variable", 1, 0, 0, scm_builtin_variable);
-
-SCM
-scm_builtin_variable (name)
- SCM name;
-{
- SCM vcell;
- SCM var_slot;
-
- SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name), name, SCM_ARG1, s_builtin_variable);
- vcell = scm_sym2vcell (name, SCM_BOOL_F, SCM_BOOL_T);
- if (vcell == SCM_BOOL_F)
- return SCM_BOOL_F;
-
- scm_intern_symbol (scm_symhash_vars, name);
- var_slot = scm_sym2ovcell (name, scm_symhash_vars);
-
- SCM_DEFER_INTS;
- if ( SCM_IMP (SCM_CDR (var_slot))
- || (SCM_VARVCELL (var_slot) != vcell))
- SCM_SETCDR (var_slot, make_vcell_variable (vcell));
- SCM_ALLOW_INTS;
-
- return SCM_CDR (var_slot);
-}
-
-
-SCM_PROC(s_variable_bound_p, "variable-bound?", 1, 0, 0, scm_variable_bound_p);
-
-SCM
-scm_variable_bound_p (var)
- SCM var;
-{
- SCM_ASSERT (SCM_NIMP(var) && SCM_VARIABLEP (var), var, SCM_ARG1, s_variable_bound_p);
- return (SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))
- ? SCM_BOOL_F
- : SCM_BOOL_T);
-}
-
-
-
-
-void
-scm_init_variable ()
-{
- scm_tc16_variable = scm_newsmob (&variable_smob);
- anonymous_variable_sym = SCM_CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED));
-#include "variable.x"
-}
-
diff --git a/libguile/variable.h b/libguile/variable.h
deleted file mode 100644
index 9bced2936..000000000
--- a/libguile/variable.h
+++ /dev/null
@@ -1,71 +0,0 @@
-/* classes: h_files */
-
-#ifndef VARIABLEH
-#define VARIABLEH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include "libguile/__scm.h"
-
-
-
-
-/* Variables
- */
-extern int scm_tc16_variable;
-
-#define SCM_VARVCELL(V) SCM_CDR(V)
-#define SCM_VARIABLEP(X) (scm_tc16_variable == SCM_CAR(X))
-#define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
-#define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
-
-
-
-extern SCM scm_make_variable SCM_P ((SCM init, SCM name_hint));
-extern SCM scm_make_undefined_variable SCM_P ((SCM name_hint));
-extern SCM scm_variable_p SCM_P ((SCM obj));
-extern SCM scm_variable_ref SCM_P ((SCM var));
-extern SCM scm_variable_set_x SCM_P ((SCM var, SCM val));
-extern SCM scm_builtin_variable SCM_P ((SCM name));
-extern SCM scm_variable_bound_p SCM_P ((SCM var));
-extern void scm_init_variable SCM_P ((void));
-
-#endif /* VARIABLEH */
diff --git a/libguile/vectors.c b/libguile/vectors.c
deleted file mode 100644
index 4484bf841..000000000
--- a/libguile/vectors.c
+++ /dev/null
@@ -1,271 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "eq.h"
-
-#include "vectors.h"
-
-
-
-SCM_PROC(s_vector_p, "vector?", 1, 0, 0, scm_vector_p);
-
-SCM
-scm_vector_p(x)
- SCM x;
-{
- if SCM_IMP(x) return SCM_BOOL_F;
- return SCM_VECTORP(x) ? SCM_BOOL_T : SCM_BOOL_F;
-}
-
-SCM_PROC(s_vector_length, "vector-length", 1, 0, 0, scm_vector_length);
-
-SCM
-scm_vector_length(v)
- SCM v;
-{
- SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_length);
- return SCM_MAKINUM(SCM_LENGTH(v));
-}
-
-SCM_PROC(s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
-SCM_PROC(s_vector, "vector", 0, 0, 1, scm_vector);
-
-SCM
-scm_vector(l)
- SCM l;
-{
- SCM res;
- register SCM *data;
- long i = scm_ilength(l);
- SCM_ASSERT(i >= 0, l, SCM_ARG1, s_vector);
- res = scm_make_vector(SCM_MAKINUM(i), SCM_UNSPECIFIED, SCM_UNDEFINED);
- data = SCM_VELTS(res);
- for(;i && SCM_NIMP(l);--i, l = SCM_CDR(l))
- *data++ = SCM_CAR(l);
- return res;
-}
-
-SCM_PROC(s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref);
-
-SCM
-scm_vector_ref(v, k)
- SCM v;
- SCM k;
-{
- SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_ref);
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_vector_ref);
- SCM_ASSERT((SCM_INUM(k) < SCM_LENGTH(v)) && (SCM_INUM(k) >= 0), k, SCM_OUTOFRANGE, s_vector_ref);
- return SCM_VELTS(v)[((long) SCM_INUM(k))];
-}
-
-
-SCM_PROC(s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x);
-
-SCM
-scm_vector_set_x(v, k, obj)
- SCM v;
- SCM k;
- SCM obj;
-{
- SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_set_x);
- SCM_ASSERT(SCM_INUMP(k), k, SCM_ARG2, s_vector_set_x);
- SCM_ASSERT((SCM_INUM(k) < SCM_LENGTH(v)) && (SCM_INUM(k) >= 0), k, SCM_OUTOFRANGE, s_vector_set_x);
- SCM_VELTS(v)[((long) SCM_INUM(k))] = obj;
- return obj;
-}
-
-
-SCM_PROC(s_make_vector, "make-vector", 1, 2, 0, scm_make_vector);
-
-SCM
-scm_make_vector(k, fill, multip)
- SCM k;
- SCM fill;
- SCM multip;
-{
- SCM v;
- int multi;
- register long i;
- register long j;
- register SCM *velts;
-
- SCM_ASSERT(SCM_INUMP(k) && (0 <= SCM_INUM (k)), k, SCM_ARG1, s_make_vector);
- if (SCM_UNBNDP(fill))
- fill = SCM_UNSPECIFIED;
- multi = !(SCM_UNBNDP(multip) || SCM_FALSEP(multip));
- i = SCM_INUM(k);
- SCM_NEWCELL(v);
- SCM_DEFER_INTS;
- SCM_SETCHARS(v, scm_must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector));
- SCM_SETLENGTH(v, i, scm_tc7_vector);
- velts = SCM_VELTS(v);
- j = 0;
- if (multi)
- {
- while ((fill != SCM_EOL) && (j < i))
- {
- (velts)[j++] = SCM_CAR (fill);
- fill = SCM_CDR (fill);
- }
- }
- while(--i >= j) (velts)[i] = fill;
- SCM_ALLOW_INTS;
- return v;
-}
-
-
-SCM_PROC(s_vector_to_list, "vector->list", 1, 0, 0, scm_vector_to_list);
-
-SCM
-scm_vector_to_list(v)
- SCM v;
-{
- SCM res = SCM_EOL;
- long i;
- SCM *data;
- SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_to_list);
- data = SCM_VELTS(v);
- for(i = SCM_LENGTH(v)-1;i >= 0;i--) res = scm_cons(data[i], res);
- return res;
-}
-
-
-SCM_PROC(s_vector_fill_x, "vector-fill!", 2, 0, 0, scm_vector_fill_x);
-
-SCM
-scm_vector_fill_x(v, fill_x)
- SCM v;
- SCM fill_x;
-{
- register long i;
- register SCM *data;
- SCM_ASSERT(SCM_NIMP(v) && SCM_VECTORP(v), v, SCM_ARG1, s_vector_fill_x);
- data = SCM_VELTS(v);
- for(i = SCM_LENGTH(v)-1;i >= 0;i--) data[i] = fill_x;
- return SCM_UNSPECIFIED;
-}
-
-
-
-SCM
-scm_vector_equal_p(x, y)
- SCM x;
- SCM y;
-{
- long i;
- for(i = SCM_LENGTH(x)-1;i >= 0;i--)
- if (SCM_FALSEP(scm_equal_p(SCM_VELTS(x)[i], SCM_VELTS(y)[i])))
- return SCM_BOOL_F;
- return SCM_BOOL_T;
-}
-
-
-SCM_PROC (s_vector_move_left_x, "vector-move-left!", 5, 0, 0, scm_vector_move_left_x);
-
-SCM
-scm_vector_move_left_x (vec1, start1, end1, vec2, start2)
- SCM vec1;
- SCM start1;
- SCM end1;
- SCM vec2;
- SCM start2;
-{
- long i;
- long j;
- long e;
-
- SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_left_x);
- SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_left_x);
- SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_left_x);
- SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_left_x);
- SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_left_x);
- i = SCM_INUM (start1);
- j = SCM_INUM (start2);
- e = SCM_INUM (end1);
- SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_left_x);
- SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_left_x);
- SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_left_x);
- SCM_ASSERT (e-i+j <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_left_x);
- while (i<e) SCM_VELTS (vec2)[j++] = SCM_VELTS (vec1)[i++];
- return SCM_UNSPECIFIED;
-}
-
-SCM_PROC (s_vector_move_right_x, "vector-move-right!", 5, 0, 0, scm_vector_move_right_x);
-
-SCM
-scm_vector_move_right_x (vec1, start1, end1, vec2, start2)
- SCM vec1;
- SCM start1;
- SCM end1;
- SCM vec2;
- SCM start2;
-{
- long i;
- long j;
- long e;
-
- SCM_ASSERT (SCM_NIMP (vec1) && SCM_VECTORP (vec1), vec1, SCM_ARG1, s_vector_move_right_x);
- SCM_ASSERT (SCM_INUMP (start1), start1, SCM_ARG2, s_vector_move_right_x);
- SCM_ASSERT (SCM_INUMP (end1), end1, SCM_ARG3, s_vector_move_right_x);
- SCM_ASSERT (SCM_NIMP (vec2) && SCM_VECTORP (vec2), vec2, SCM_ARG4, s_vector_move_right_x);
- SCM_ASSERT (SCM_INUMP (start2), start2, SCM_ARG5, s_vector_move_right_x);
- i = SCM_INUM (start1);
- j = SCM_INUM (start2);
- e = SCM_INUM (end1);
- SCM_ASSERT (i <= SCM_LENGTH (vec1) && i >= 0, start1, SCM_OUTOFRANGE, s_vector_move_right_x);
- SCM_ASSERT (j <= SCM_LENGTH (vec2) && j >= 0, start2, SCM_OUTOFRANGE, s_vector_move_right_x);
- SCM_ASSERT (e <= SCM_LENGTH (vec1) && e >= 0, end1, SCM_OUTOFRANGE, s_vector_move_right_x);
- SCM_ASSERT ((j = e-i+j) <= SCM_LENGTH (vec2), start2, SCM_OUTOFRANGE, s_vector_move_right_x);
- while (i<e) SCM_VELTS (vec2)[--j] = SCM_VELTS (vec1)[--e];
- return SCM_UNSPECIFIED;
-}
-
-
-
-void
-scm_init_vectors ()
-{
-#include "vectors.x"
-}
-
diff --git a/libguile/vectors.h b/libguile/vectors.h
deleted file mode 100644
index 5b98afbcc..000000000
--- a/libguile/vectors.h
+++ /dev/null
@@ -1,73 +0,0 @@
-/* classes: h_files */
-
-#ifndef VECTORSH
-#define VECTORSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-#define SCM_VECTORP(x) (SCM_TYP7S(x)==scm_tc7_vector)
-#define SCM_NVECTORP(x) (!SCM_VECTORP(x))
-#define SCM_VELTS(x) ((SCM *)SCM_CDR(x))
-#define SCM_SETVELTS SCM_SETCDR
-
-
-
-extern SCM scm_vector_p SCM_P ((SCM x));
-extern SCM scm_vector_length SCM_P ((SCM v));
-extern SCM scm_vector SCM_P ((SCM l));
-extern SCM scm_vector_ref SCM_P ((SCM v, SCM k));
-extern SCM scm_vector_set_x SCM_P ((SCM v, SCM k, SCM obj));
-extern SCM scm_make_vector SCM_P ((SCM k, SCM fill, SCM multi));
-extern SCM scm_vector_to_list SCM_P ((SCM v));
-extern SCM scm_vector_fill_x SCM_P ((SCM v, SCM fill_x));
-extern SCM scm_vector_equal_p SCM_P ((SCM x, SCM y));
-extern SCM scm_vector_move_left_x SCM_P ((SCM vec1, SCM start1, SCM end1, SCM
- vec2, SCM start2));
-extern SCM scm_vector_move_right_x SCM_P ((SCM vec1, SCM start1, SCM end1, SCM
- vec2, SCM start2));
-extern void scm_init_vectors SCM_P ((void));
-
-#endif /* VECTORSH */
diff --git a/libguile/version.c b/libguile/version.c
deleted file mode 100644
index 889b08efc..000000000
--- a/libguile/version.c
+++ /dev/null
@@ -1,85 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "_scm.h"
-
-#include "version.h"
-
-
-/* Return a Scheme string containing Guile's major version number. */
-
-SCM_PROC(s_major_version, "major-version", 0, 0, 0, scm_major_version);
-
-SCM
-scm_major_version ()
-{
- return scm_makfrom0str (GUILE_MAJOR_VERSION);
-}
-
-/* Return a Scheme string containing Guile's minor version number. */
-
-SCM_PROC(s_minor_version, "minor-version", 0, 0, 0, scm_minor_version);
-
-SCM
-scm_minor_version ()
-{
- return scm_makfrom0str (GUILE_MINOR_VERSION);
-}
-
-/* Return a Scheme string containing Guile's complete version. */
-
-SCM_PROC(s_version, "version", 0, 0, 0, scm_version);
-
-SCM
-scm_version ()
-{
- return scm_makfrom0str (GUILE_VERSION);
-}
-
-
-
-
-void
-scm_init_version ()
-{
-#include "version.x"
-}
diff --git a/libguile/version.h b/libguile/version.h
deleted file mode 100644
index ff48cf231..000000000
--- a/libguile/version.h
+++ /dev/null
@@ -1,56 +0,0 @@
-/* classes: h_files */
-
-#ifndef VERSIONH
-#define VERSIONH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-extern SCM scm_major_version SCM_P ((void));
-extern SCM scm_minor_version SCM_P ((void));
-extern SCM scm_version SCM_P ((void));
-extern void scm_init_version SCM_P ((void));
-
-#endif /* VERSIONH */
diff --git a/libguile/vports.c b/libguile/vports.c
deleted file mode 100644
index 89e398e98..000000000
--- a/libguile/vports.c
+++ /dev/null
@@ -1,226 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include <stdio.h>
-#include "_scm.h"
-#include "eval.h"
-#include "chars.h"
-#include "fports.h"
-
-#include "vports.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-
-
-
-/* {Ports - soft ports}
- *
- */
-
-
-
-static int prinsfpt SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
-
-static int
-prinsfpt (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- scm_prinport (exp, port, "soft");
- return !0;
-}
-
-/* sfputc sfwrite sfputs sfclose
- * are called within a SCM_SYSCALL.
- *
- * So we need to set errno to 0 before returning. sfflush
- * may be called within a SCM_SYSCALL. So we need to set errno to 0
- * before returning.
- */
-
-
-static int sfputc SCM_P ((int c, SCM p));
-
-static int
-sfputc (c, p)
- int c;
- SCM p;
-{
- scm_apply (SCM_VELTS (p)[0], SCM_MAKICHR (c), scm_listofnull);
- errno = 0;
- return c;
-}
-
-
-static scm_sizet sfwrite SCM_P ((char *str, scm_sizet siz, scm_sizet num, SCM p));
-
-static scm_sizet
-sfwrite (str, siz, num, p)
- char *str;
- scm_sizet siz;
- scm_sizet num;
- SCM p;
-{
- SCM sstr;
- sstr = scm_makfromstr (str, siz * num, 0);
- scm_apply (SCM_VELTS (p)[1], sstr, scm_listofnull);
- errno = 0;
- return num;
-}
-
-
-static int sfputs SCM_P ((char *s, SCM p));
-
-static int
-sfputs (s, p)
- char *s;
- SCM p;
-{
- sfwrite (s, 1, strlen (s), p);
- return 0;
-}
-
-
-static int sfflush SCM_P ((SCM stream));
-
-static int
-sfflush (stream)
- SCM stream;
-{
- SCM f = SCM_VELTS (stream)[2];
- if (SCM_BOOL_F == f)
- return 0;
- f = scm_apply (f, SCM_EOL, SCM_EOL);
- errno = 0;
- return SCM_BOOL_F == f ? EOF : 0;
-}
-
-
-static int sfgetc SCM_P ((SCM p));
-
-static int
-sfgetc (p)
- SCM p;
-{
- SCM ans;
- ans = scm_apply (SCM_VELTS (p)[3], SCM_EOL, SCM_EOL);
- errno = 0;
- if (SCM_FALSEP (ans) || SCM_EOF_VAL == ans)
- return EOF;
- SCM_ASSERT (SCM_ICHRP (ans), ans, SCM_ARG1, "getc");
- return SCM_ICHR (ans);
-}
-
-
-static int sfclose SCM_P ((SCM p));
-
-static int
-sfclose (p)
- SCM p;
-{
- SCM f = SCM_VELTS (p)[4];
- if (SCM_BOOL_F == f)
- return 0;
- f = scm_apply (f, SCM_EOL, SCM_EOL);
- errno = 0;
- return SCM_BOOL_F == f ? EOF : 0;
-}
-
-
-
-SCM_PROC(s_make_soft_port, "make-soft-port", 2, 0, 0, scm_make_soft_port);
-
-SCM
-scm_make_soft_port (pv, modes)
- SCM pv;
- SCM modes;
-{
- struct scm_port_table * pt;
- SCM z;
- SCM_ASSERT (SCM_NIMP (pv) && SCM_VECTORP (pv) && 5 == SCM_LENGTH (pv), pv, SCM_ARG1, s_make_soft_port);
- SCM_ASSERT (SCM_NIMP (modes) && SCM_STRINGP (modes), modes, SCM_ARG2, s_make_soft_port);
- SCM_NEWCELL (z);
- SCM_DEFER_INTS;
- pt = scm_add_to_port_table (z);
- SCM_SETCAR (z, scm_tc16_sfport | scm_mode_bits (SCM_CHARS (modes)));
- SCM_SETPTAB_ENTRY (z, pt);
- SCM_SETSTREAM (z, pv);
- SCM_ALLOW_INTS;
- return z;
-}
-
-
-static int noop0 SCM_P ((SCM stream));
-
-static int
-noop0 (stream)
- SCM stream;
-{
- return 0;
-}
-
-
-scm_ptobfuns scm_sfptob =
-{
- scm_markstream,
- noop0,
- prinsfpt,
- 0,
- sfputc,
- sfputs,
- sfwrite,
- sfflush,
- sfgetc,
- sfclose
-};
-
-
-
-void
-scm_init_vports ()
-{
-#include "vports.x"
-}
-
diff --git a/libguile/vports.h b/libguile/vports.h
deleted file mode 100644
index 27b14a3d6..000000000
--- a/libguile/vports.h
+++ /dev/null
@@ -1,59 +0,0 @@
-/* classes: h_files */
-
-#ifndef VPORTSH
-#define VPORTSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-extern scm_ptobfuns scm_sfptob;
-
-
-
-
-
-
-extern SCM scm_make_soft_port SCM_P ((SCM pv, SCM modes));
-extern void scm_init_vports SCM_P ((void));
-
-#endif /* VPORTSH */
diff --git a/libguile/weaks.c b/libguile/weaks.c
deleted file mode 100644
index cb2912970..000000000
--- a/libguile/weaks.c
+++ /dev/null
@@ -1,203 +0,0 @@
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, Free Software Foundation gives permission
- * for additional uses of the text contained in its release of this library.
- *
- * The exception is that, if you link this library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking this library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by
- * Free Software Foundation as part of this library. If you copy
- * code from other releases distributed under the terms of the GPL into a copy of
- * this library, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from such code.
- *
- * If you write modifications of your own for this library, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-#include <stdio.h>
-#include "_scm.h"
-
-#include "weaks.h"
-
-
-
-/* {Weak Vectors}
- */
-
-
-SCM_PROC(s_make_weak_vector, "make-weak-vector", 1, 1, 0, scm_make_weak_vector);
-
-SCM
-scm_make_weak_vector (k, fill)
- SCM k;
- SCM fill;
-{
- SCM v;
- v = scm_make_vector (scm_sum (k, SCM_MAKINUM (1)), fill, SCM_UNDEFINED);
- SCM_DEFER_INTS;
- SCM_SETLENGTH(v, SCM_INUM (k), scm_tc7_wvect);
- SCM_VELTS(v)[0] = (SCM)0;
- SCM_SETVELTS(v, SCM_VELTS(v) + 1);
- SCM_ALLOW_INTS;
- return v;
-}
-
-
-SCM_PROC(s_weak_vector, "weak-vector", 0, 0, 1, scm_weak_vector);
-SCM_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
-
-SCM
-scm_weak_vector (l)
- SCM l;
-{
- SCM res;
- register SCM *data;
- long i;
-
- i = scm_ilength (l);
- SCM_ASSERT (i >= 0, l, SCM_ARG1, s_weak_vector);
- res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED);
- data = SCM_VELTS (res);
- for (;
- i && SCM_NIMP (l) && SCM_CONSP (l);
- --i, l = SCM_CDR (l))
- *data++ = SCM_CAR (l);
- return res;
-}
-
-
-SCM_PROC(s_weak_vector_p, "weak-vector?", 1, 0, 0, scm_weak_vector_p);
-
-SCM
-scm_weak_vector_p (x)
- SCM x;
-{
- return ((SCM_NIMP (x) && SCM_WVECTP (x) && !SCM_IS_WHVEC (x))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-
-
-
-
-
-SCM_PROC(s_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0, scm_make_weak_key_hash_table);
-
-SCM
-scm_make_weak_key_hash_table (k)
- SCM k;
-{
- SCM v;
- SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_key_hash_table);
- v = scm_make_weak_vector (k, SCM_EOL);
- SCM_ALLOW_INTS;
- SCM_VELTS (v)[-1] = 1;
- SCM_ALLOW_INTS;
- return v;
-}
-
-
-SCM_PROC (s_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0, 0, scm_make_weak_value_hash_table);
-
-SCM
-scm_make_weak_value_hash_table (k)
- SCM k;
-{
- SCM v;
- SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_weak_value_hash_table);
- v = scm_make_weak_vector (k, SCM_EOL);
- SCM_ALLOW_INTS;
- SCM_VELTS (v)[-1] = 2;
- SCM_ALLOW_INTS;
- return v;
-}
-
-
-
-SCM_PROC (s_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, scm_make_doubly_weak_hash_table);
-
-SCM
-scm_make_doubly_weak_hash_table (k)
- SCM k;
-{
- SCM v;
- SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG1, s_make_doubly_weak_hash_table);
- v = scm_make_weak_vector (k, SCM_EOL);
- SCM_ALLOW_INTS;
- SCM_VELTS (v)[-1] = 3;
- SCM_ALLOW_INTS;
- return v;
-}
-
-SCM_PROC(s_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, scm_weak_key_hash_table_p);
-
-SCM
-scm_weak_key_hash_table_p (x)
- SCM x;
-{
- return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC(x))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-SCM_PROC (s_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, scm_weak_value_hash_table_p);
-
-SCM
-scm_weak_value_hash_table_p (x)
- SCM x;
-{
- return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_V(x))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-SCM_PROC (s_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, scm_doubly_weak_hash_table_p);
-
-SCM
-scm_doubly_weak_hash_table_p (x)
- SCM x;
-{
- return ((SCM_NIMP (x) && SCM_WVECTP (x) && SCM_IS_WHVEC_B (x))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
-}
-
-
-
-
-
-void
-scm_init_weaks ()
-{
-#include "weaks.x"
-}
-
diff --git a/libguile/weaks.h b/libguile/weaks.h
deleted file mode 100644
index 8a6eb467d..000000000
--- a/libguile/weaks.h
+++ /dev/null
@@ -1,71 +0,0 @@
-/* classes: h_files */
-
-#ifndef WEAKSH
-#define WEAKSH
-/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice.
- */
-
-
-#include "libguile/__scm.h"
-
-
-
-
-#define SCM_WVECTP(x) (SCM_TYP7(x)==scm_tc7_wvect)
-#define SCM_IS_WHVEC(X) (SCM_VELTS(X)[-1] == 1)
-#define SCM_IS_WHVEC_V(X) (SCM_VELTS(X)[-1] == 2)
-#define SCM_IS_WHVEC_B(X) (SCM_VELTS(X)[-1] == 3)
-#define SCM_IS_WHVEC_ANY(X) (SCM_VELTS(X)[-1])
-
-
-
-extern SCM scm_make_weak_vector SCM_P ((SCM k, SCM fill));
-extern SCM scm_weak_vector SCM_P ((SCM l));
-extern SCM scm_weak_vector_p SCM_P ((SCM x));
-extern SCM scm_make_weak_key_hash_table SCM_P ((SCM k));
-extern SCM scm_make_weak_value_hash_table SCM_P ((SCM k));
-extern SCM scm_make_doubly_weak_hash_table SCM_P ((SCM k));
-extern SCM scm_weak_key_hash_table_p SCM_P ((SCM x));
-extern SCM scm_weak_value_hash_table_p SCM_P ((SCM x));
-extern SCM scm_doubly_weak_hash_table_p SCM_P ((SCM x));
-extern void scm_init_weaks SCM_P ((void));
-
-#endif /* WEAKSH */