summaryrefslogtreecommitdiff
path: root/ice-9
diff options
context:
space:
mode:
Diffstat (limited to 'ice-9')
-rw-r--r--ice-9/.cvsignore3
-rw-r--r--ice-9/COPYING339
-rw-r--r--ice-9/ChangeLog463
-rw-r--r--ice-9/Makefile.am10
-rw-r--r--ice-9/Makefile.in207
-rw-r--r--ice-9/aclocal.m464
-rw-r--r--ice-9/boot-9.scm3479
-rwxr-xr-xice-9/configure961
-rw-r--r--ice-9/configure.in7
-rw-r--r--ice-9/debug.scm120
-rw-r--r--ice-9/expect.scm125
-rw-r--r--ice-9/hcons.scm76
-rw-r--r--ice-9/lineio.scm112
-rw-r--r--ice-9/mapping.scm121
-rw-r--r--ice-9/poe.scm117
-rw-r--r--ice-9/r4rs.scm149
-rw-r--r--ice-9/slib.scm188
-rw-r--r--ice-9/tags.scm23
-rw-r--r--ice-9/test.scm1032
-rw-r--r--ice-9/threads.scm53
20 files changed, 0 insertions, 7649 deletions
diff --git a/ice-9/.cvsignore b/ice-9/.cvsignore
deleted file mode 100644
index 16b8c4510..000000000
--- a/ice-9/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-Makefile
-config.log
-config.status
diff --git a/ice-9/COPYING b/ice-9/COPYING
deleted file mode 100644
index 9648fb9ea..000000000
--- a/ice-9/COPYING
+++ /dev/null
@@ -1,339 +0,0 @@
- GNU GENERAL PUBLIC LICENSE
- Version 2, June 1991
-
- Copyright (C) 1989, 1991, 1992, 1993 Free Software Foundation, Inc.
- 675 Mass Ave, Cambridge, MA 02139, USA
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- Preamble
-
- The licenses for most software are designed to take away your
-freedom to share and change it. By contrast, the GNU General Public
-License is intended to guarantee your freedom to share and change free
-software--to make sure the software is free for all its users. This
-General Public License applies to most of the Free Software
-Foundation's software and to any other program whose authors commit to
-using it. (Some other Free Software Foundation software is covered by
-the GNU Library General Public License instead.) You can apply it to
-your programs, too.
-
- When we speak of free software, we are referring to freedom, not
-price. Our General Public Licenses are designed to make sure that you
-have the freedom to distribute copies of free software (and charge for
-this service if you wish), that you receive source code or can get it
-if you want it, that you can change the software or use pieces of it
-in new free programs; and that you know you can do these things.
-
- To protect your rights, we need to make restrictions that forbid
-anyone to deny you these rights or to ask you to surrender the rights.
-These restrictions translate to certain responsibilities for you if you
-distribute copies of the software, or if you modify it.
-
- For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must give the recipients all the rights that
-you have. You must make sure that they, too, receive or can get the
-source code. And you must show them these terms so they know their
-rights.
-
- We protect your rights with two steps: (1) copyright the software, and
-(2) offer you this license which gives you legal permission to copy,
-distribute and/or modify the software.
-
- Also, for each author's protection and ours, we want to make certain
-that everyone understands that there is no warranty for this free
-software. If the software is modified by someone else and passed on, we
-want its recipients to know that what they have is not the original, so
-that any problems introduced by others will not reflect on the original
-authors' reputations.
-
- Finally, any free program is threatened constantly by software
-patents. We wish to avoid the danger that redistributors of a free
-program will individually obtain patent licenses, in effect making the
-program proprietary. To prevent this, we have made it clear that any
-patent must be licensed for everyone's free use or not licensed at all.
-
- The precise terms and conditions for copying, distribution and
-modification follow.
-
- GNU GENERAL PUBLIC LICENSE
- TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
-
- 0. This License applies to any program or other work which contains
-a notice placed by the copyright holder saying it may be distributed
-under the terms of this General Public License. The "Program", below,
-refers to any such program or work, and a "work based on the Program"
-means either the Program or any derivative work under copyright law:
-that is to say, a work containing the Program or a portion of it,
-either verbatim or with modifications and/or translated into another
-language. (Hereinafter, translation is included without limitation in
-the term "modification".) Each licensee is addressed as "you".
-
-Activities other than copying, distribution and modification are not
-covered by this License; they are outside its scope. The act of
-running the Program is not restricted, and the output from the Program
-is covered only if its contents constitute a work based on the
-Program (independent of having been made by running the Program).
-Whether that is true depends on what the Program does.
-
- 1. You may copy and distribute verbatim copies of the Program's
-source code as you receive it, in any medium, provided that you
-conspicuously and appropriately publish on each copy an appropriate
-copyright notice and disclaimer of warranty; keep intact all the
-notices that refer to this License and to the absence of any warranty;
-and give any other recipients of the Program a copy of this License
-along with the Program.
-
-You may charge a fee for the physical act of transferring a copy, and
-you may at your option offer warranty protection in exchange for a fee.
-
- 2. You may modify your copy or copies of the Program or any portion
-of it, thus forming a work based on the Program, and copy and
-distribute such modifications or work under the terms of Section 1
-above, provided that you also meet all of these conditions:
-
- a) You must cause the modified files to carry prominent notices
- stating that you changed the files and the date of any change.
-
- b) You must cause any work that you distribute or publish, that in
- whole or in part contains or is derived from the Program or any
- part thereof, to be licensed as a whole at no charge to all third
- parties under the terms of this License.
-
- c) If the modified program normally reads commands interactively
- when run, you must cause it, when started running for such
- interactive use in the most ordinary way, to print or display an
- announcement including an appropriate copyright notice and a
- notice that there is no warranty (or else, saying that you provide
- a warranty) and that users may redistribute the program under
- these conditions, and telling the user how to view a copy of this
- License. (Exception: if the Program itself is interactive but
- does not normally print such an announcement, your work based on
- the Program is not required to print an announcement.)
-
-These requirements apply to the modified work as a whole. If
-identifiable sections of that work are not derived from the Program,
-and can be reasonably considered independent and separate works in
-themselves, then this License, and its terms, do not apply to those
-sections when you distribute them as separate works. But when you
-distribute the same sections as part of a whole which is a work based
-on the Program, the distribution of the whole must be on the terms of
-this License, whose permissions for other licensees extend to the
-entire whole, and thus to each and every part regardless of who wrote it.
-
-Thus, it is not the intent of this section to claim rights or contest
-your rights to work written entirely by you; rather, the intent is to
-exercise the right to control the distribution of derivative or
-collective works based on the Program.
-
-In addition, mere aggregation of another work not based on the Program
-with the Program (or with a work based on the Program) on a volume of
-a storage or distribution medium does not bring the other work under
-the scope of this License.
-
- 3. You may copy and distribute the Program (or a work based on it,
-under Section 2) in object code or executable form under the terms of
-Sections 1 and 2 above provided that you also do one of the following:
-
- a) Accompany it with the complete corresponding machine-readable
- source code, which must be distributed under the terms of Sections
- 1 and 2 above on a medium customarily used for software interchange; or,
-
- b) Accompany it with a written offer, valid for at least three
- years, to give any third party, for a charge no more than your
- cost of physically performing source distribution, a complete
- machine-readable copy of the corresponding source code, to be
- distributed under the terms of Sections 1 and 2 above on a medium
- customarily used for software interchange; or,
-
- c) Accompany it with the information you received as to the offer
- to distribute corresponding source code. (This alternative is
- allowed only for noncommercial distribution and only if you
- received the program in object code or executable form with such
- an offer, in accord with Subsection b above.)
-
-The source code for a work means the preferred form of the work for
-making modifications to it. For an executable work, complete source
-code means all the source code for all modules it contains, plus any
-associated interface definition files, plus the scripts used to
-control compilation and installation of the executable. However, as a
-special exception, the source code distributed need not include
-anything that is normally distributed (in either source or binary
-form) with the major components (compiler, kernel, and so on) of the
-operating system on which the executable runs, unless that component
-itself accompanies the executable.
-
-If distribution of executable or object code is made by offering
-access to copy from a designated place, then offering equivalent
-access to copy the source code from the same place counts as
-distribution of the source code, even though third parties are not
-compelled to copy the source along with the object code.
-
- 4. You may not copy, modify, sublicense, or distribute the Program
-except as expressly provided under this License. Any attempt
-otherwise to copy, modify, sublicense or distribute the Program is
-void, and will automatically terminate your rights under this License.
-However, parties who have received copies, or rights, from you under
-this License will not have their licenses terminated so long as such
-parties remain in full compliance.
-
- 5. You are not required to accept this License, since you have not
-signed it. However, nothing else grants you permission to modify or
-distribute the Program or its derivative works. These actions are
-prohibited by law if you do not accept this License. Therefore, by
-modifying or distributing the Program (or any work based on the
-Program), you indicate your acceptance of this License to do so, and
-all its terms and conditions for copying, distributing or modifying
-the Program or works based on it.
-
- 6. Each time you redistribute the Program (or any work based on the
-Program), the recipient automatically receives a license from the
-original licensor to copy, distribute or modify the Program subject to
-these terms and conditions. You may not impose any further
-restrictions on the recipients' exercise of the rights granted herein.
-You are not responsible for enforcing compliance by third parties to
-this License.
-
- 7. If, as a consequence of a court judgment or allegation of patent
-infringement or for any other reason (not limited to patent issues),
-conditions are imposed on you (whether by court order, agreement or
-otherwise) that contradict the conditions of this License, they do not
-excuse you from the conditions of this License. If you cannot
-distribute so as to satisfy simultaneously your obligations under this
-License and any other pertinent obligations, then as a consequence you
-may not distribute the Program at all. For example, if a patent
-license would not permit royalty-free redistribution of the Program by
-all those who receive copies directly or indirectly through you, then
-the only way you could satisfy both it and this License would be to
-refrain entirely from distribution of the Program.
-
-If any portion of this section is held invalid or unenforceable under
-any particular circumstance, the balance of the section is intended to
-apply and the section as a whole is intended to apply in other
-circumstances.
-
-It is not the purpose of this section to induce you to infringe any
-patents or other property right claims or to contest validity of any
-such claims; this section has the sole purpose of protecting the
-integrity of the free software distribution system, which is
-implemented by public license practices. Many people have made
-generous contributions to the wide range of software distributed
-through that system in reliance on consistent application of that
-system; it is up to the author/donor to decide if he or she is willing
-to distribute software through any other system and a licensee cannot
-impose that choice.
-
-This section is intended to make thoroughly clear what is believed to
-be a consequence of the rest of this License.
-
- 8. If the distribution and/or use of the Program is restricted in
-certain countries either by patents or by copyrighted interfaces, the
-original copyright holder who places the Program under this License
-may add an explicit geographical distribution limitation excluding
-those countries, so that distribution is permitted only in or among
-countries not thus excluded. In such case, this License incorporates
-the limitation as if written in the body of this License.
-
- 9. The Free Software Foundation may publish revised and/or new versions
-of the General Public License from time to time. Such new versions will
-be similar in spirit to the present version, but may differ in detail to
-address new problems or concerns.
-
-Each version is given a distinguishing version number. If the Program
-specifies a version number of this License which applies to it and "any
-later version", you have the option of following the terms and conditions
-either of that version or of any later version published by the Free
-Software Foundation. If the Program does not specify a version number of
-this License, you may choose any version ever published by the Free Software
-Foundation.
-
- 10. If you wish to incorporate parts of the Program into other free
-programs whose distribution conditions are different, write to the author
-to ask for permission. For software which is copyrighted by the Free
-Software Foundation, write to the Free Software Foundation; we sometimes
-make exceptions for this. Our decision will be guided by the two goals
-of preserving the free status of all derivatives of our free software and
-of promoting the sharing and reuse of software generally.
-
- NO WARRANTY
-
- 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
-FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
-OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
-PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
-OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
-TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
-PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
-REPAIR OR CORRECTION.
-
- 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
-WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
-REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
-INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
-OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
-TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
-YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
-PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGES.
-
- END OF TERMS AND CONDITIONS
-
- Appendix: How to Apply These Terms to Your New Programs
-
- If you develop a new program, and you want it to be of the greatest
-possible use to the public, the best way to achieve this is to make it
-free software which everyone can redistribute and change under these terms.
-
- To do so, attach the following notices to the program. It is safest
-to attach them to the start of each source file to most effectively
-convey the exclusion of warranty; and each file should have at least
-the "copyright" line and a pointer to where the full notice is found.
-
- <one line to give the program's name and a brief idea of what it does.>
- Copyright (C) 19yy <name of author>
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-Also add information on how to contact you by electronic and paper mail.
-
-If the program is interactive, make it output a short notice like this
-when it starts in an interactive mode:
-
- Gnomovision version 69, Copyright (C) 19yy name of author
- Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
- This is free software, and you are welcome to redistribute it
- under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License. Of course, the commands you use may
-be called something other than `show w' and `show c'; they could even be
-mouse-clicks or menu items--whatever suits your program.
-
-You should also get your employer (if you work as a programmer) or your
-school, if any, to sign a "copyright disclaimer" for the program, if
-necessary. Here is a sample; alter the names:
-
- Yoyodyne, Inc., hereby disclaims all copyright interest in the program
- `Gnomovision' (which makes passes at compilers) written by James Hacker.
-
- <signature of Ty Coon>, 1 April 1989
- Ty Coon, President of Vice
-
-This General Public License does not permit incorporating your program into
-proprietary programs. If your program is a subroutine library, you may
-consider it more useful to permit linking proprietary applications with the
-library. If this is what you want to do, use the GNU Library General
-Public License instead of this License.
diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
deleted file mode 100644
index c41e52b6f..000000000
--- a/ice-9/ChangeLog
+++ /dev/null
@@ -1,463 +0,0 @@
-Wed Dec 11 21:06:05 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * slib.scm (slib-parent-dir): throw error if #f returned from
- %search-load-path.
-
-Sat Nov 30 23:57:28 1996 Tom Tromey <tromey@cygnus.com>
-
- * PLUGIN/greet, PLUGIN/split.sed, PLUGIN/this.configure: Removed.
- * Makefile.am, aclocal.m4: New files.
- * configure.in: Updated for Automake.
-
-Wed Nov 27 14:16:14 1996 Marius Vollmer <mvo@zagadka.ping.de>
-
- * boot-9.scm (macroexpand-1, macroexpand), slib.scm
- (slib:features), r4rs.scm (%load-verbosely): "defined?" is now a
- function, use it accordingly.
-
-Thu Nov 21 11:12:10 1996 Jim Blandy <jimb@floss.cyclic.com>
-
- It's an "eval closure", not an "eval thunk." A thunk is a
- function of no arguments.
- * boot-9.scm (module-type): Rename module field.
- (make-module, eval-in-module, make-root-module,
- set-current-module): Uses changed.
- (module-eval-closure, set-module-eval-closure!,
- root-module-closure): Renamed from module-eval-thunk,
- set-module-eval-thunk!, root-module-thunk.
- (set-current-module): Change uses of *top-level-lookup-thunk* to
- *top-level-eval-closure*.
-
-Wed Nov 20 14:45:27 1996 Jim Blandy <jimb@totoro.cyclic.com>
-
- * slib.scm (slib-parent-dir): Use string-length, not length.
- (Thanks to Bernard Urban.)
-
-Sat Nov 2 20:00:42 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
-
-* * boot-9.scm: The debugging evaluator and recording of positions
- aren't enabled by default any longer (they are switched on in
- debug.scm). But during development we want to have them also
- *inside* boot-9.scm. Therefore, two lines are added at the
- beginning of boot-9.scm to enable these.
-
- Call `provide' so that `records' are included among the
- `*features*'.
-
- The scheme for saving the stack has been adjusted: save-stack is
- now commonly available for saving the stack. Calling `save-stack'
- sets a flag `stack-saved?' which prevents overwriting the stack.
- `stack-saved?' is reset at `abort'.
-
- Spelling correction: seperate --> separate.
-
- Removed `:'s that had creeped into some comments.
-
-* The repl now doesn't print #<unspecified> results any longer
- If the user wants to see this, he can do
- (assert-repl-print-unspecified #t) in his startup file.
-
-* The user now gets a friendly message instead of a backtrace at
- error.
-
- Added `before-read-hook'.
-
- Load module (ice-9 emacs) if option `-e' was specified.
-
- (provide): New function.
-
- (error): Save stack at entry, so that Guile entrails won't show up
- in backtraces.
-
- (backtrace): New function.
-
-* (save-stack): Can now take arbitrary number of stack narrowing
- specifier pairs. The first specifier in a pair controls inner
- border, the second the outer border. A number means cut that
- number of frames, a procedure object means cut until that object
- is found in operator position in a frame.
-
- * debug.scm: Enable debugging evaluator and recording of positions
- by default.
-
- * slib.scm (slib:load): Adapt to the new behavior of
- primitive-load: It doesn't any longer try both with and without
- ".scm" extension. (We don't want to use %search-load-path here.)
-
- (implementation-vicinity): New function. slib requires it
-
- (library-vicinity): Updated.
-
- Load "require.scm" in the library-vicinity.
-
- (install-require-vicinity, install-require-module): New functions.
-
-Mon Oct 28 17:56:29 1996 Jim Blandy <jimb@floss.cyclic.com>
-
- * boot-9.scm (load-from-path): New function.
-
- * boot-9.scm (try-load, basic-try-load, try-load-module,
- try-load): Deleted. I don't think they're being used.
-
- * Makefile.in (scm_files): Add r4rs.scm and test.scm to this list,
- so they'll get distributed.
-
- Get Guile to be a little less chatty by default. The new user
- should see as little clutter as possible.
- * r4rs.scm (%load-verbosely): Make this #f by default.
- * boot-9.scm (scm-repl-verbose): Make this #f by default.
- (scm-style-repl): Don't run 'pk' on the value passed to quit.
-
- * r4rs.scm: New file.
- * boot-9.scm: Load r4rs.scm, first thing.
- (OPEN_READ, OPEN_WRITE, OPEN_BOTH, *null-device*, open-input-file,
- open-output-file, open-io-file, close-input-port,
- close-output-port, close-io-port, call-with-input-file,
- call-with-output-file, with-input-from-port, with-output-to-port,
- with-error-to-port, with-input-from-file, with-output-to-file,
- with-error-to-file, with-input-from-string, with-output-to-string,
- with-error-to-string, the-eof-object): Definitions moved to
- r4rs.scm. Not all of them are R4RS, but those that are use those
- that are not.
- (load, %load-verbosely, %load-announce): Moved, along with code to
- set %load-hook, to r4rs.scm.
-
- * test.scm: New file.
-
- * boot-9.scm (integer?): Definition deleted, in favor of the one
- present in libguile (which used to be called int?). I have no
- idea why integer? didn't just call int? to begin with.
-
- * boot-9.scm (<, <=, =, >, >=): Definitions in terms of <?, <=?,
- =?, >?, and >=? deleted; they're defined that way by libguile now.
-
- * boot-9.scm (load): Simplified; primitive-load does most of this
- work now.
- (%load-announce-win): Removed; no longer used. Set %load-hook to
- call %load-announce.
-
-Sun Oct 27 07:47:03 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm (stat:dev, stat:ino, stat:mode, stat:nlink, stat:uid,
- stat:gid, stat:rdev, stat:size, stat:atime, stat:mtime,
- stat:ctime, stat:blksize, stat:blocks) accessor functions for stat
- components.
- (file-is-directory?): use stat:type.
-
-Fri Oct 25 03:34:47 1996 Jim Blandy <jimb@floss.cyclic.com>
-
- * boot-9.scm (%read-sharp): Don't recognize the `#!' syntax here;
- that's now taken care of in libguile, and in a way compatible with
- SCSH (which this isn't).
-
-Mon Oct 21 18:52:36 1996 Jim Blandy <jimb@totoro.cyclic.com>
-
- * boot-9.scm: Formatting tweaks.
-
-Fri Oct 18 01:03:08 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
-
- * boot-9.scm (handle-system-error): Added hooks before-error-hook,
- after-error-hook, before-backtrace-hook and after-backtrace-hook
- to the error handler. E.g.: fancy emacs support could plug into
- these.
- (save-stack): New function. The stack is now made differently
- depending on the stack id. (The motivation is to make a better
- choice regarding what stack frames to present to the user.)
- (error-catching-loop): Stack handling code moved outside into
- save-stack.
-
-Thu Oct 17 20:33:08 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * Makefile.in (scm_files): add expect.scm.
-
- * expect.scm: new file ported from guile-iii.
-
- * boot-9.scm: remove handle-system-error, after moving the code into
- error-catching-loop.
- Don't set 'throw-handler-default property on error keys.
- Just interpret (almost) any throw with 4 args as an error throw.
- Delete some try-load stuff that was already commented out.
-
- Second thoughts, keep handle-system-error but call it from
- error-catching-loop.
-
-Tue Oct 15 17:07:20 1996 Jim Blandy <jimb@floss.cyclic.com>
-
- * boot-9.scm: Doc fixes.
- (make-module): Rework for readability.
- (make-root-module, make-scm-module): USES argument to make-module
- should be '(), not #f.
-
- * boot-9.scm (try-load): %sys-load-path has been renamed to
- primitive-load-path; adjust call here.
-
-Tue Oct 15 14:25:01 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
-
- * boot-9.scm (signal-handler): Bugfix: Moved the recording of
- the stack to the correct place: when it is decided to generate an
- error-signal.
-
-Mon Oct 14 22:20:30 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
-
- * boot-9.scm (error-catching-loop, signal-handler,
- handle-system-error): Backtracing now works for signals aswell;
- Backtracing mechanism can now identify the stack root created by
- start-stack so that the user isn't exposed to system stack frames.
-
-Mon Oct 14 06:05:42 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
-
- * Makefile.in: Added threads.scm.
-
-Mon Oct 14 04:21:51 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
-
- * debug.scm (make-enable, make-disable): Simplified.
-
- * boot-9.scm: Renamed %%throw-handler-default -->
- throw-handler-default.
- ((handle-system-error key . arg-list)): Changed the way errors are
- reported.
- ((scm-style-repl)): Wrap up the call to eval in a start-stack
- acro.
- ((error-catching-loop thunk)): Introduce a lazy-catch into
- error-catching-loop so that the stack can be captured.
-
-Thu Oct 10 22:27:32 1996 Jim Blandy <jimb@totoro.cyclic.com>
-
- * mapping.scm (hash-table-mapping): Explicitly request that
- make-vector fill new vectors with '(); this will make it easier to
- port Guile Scheme code to other Schemes.
- * boot-9.scm (make-print-style, make-print-table): Same.
-
-Sun Oct 6 03:54:59 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm (load): rewritten again.
- Append "." to the default %load-path.
- (feature?): new function: checks for a symbol in the features list.
- (module-local-variable): remove apparently useless (caddr (list m v
- ...))
- (%load-announce): minor formatting change.
- (file-exists?): use access? if posix is featured.
- (file-is-directory?): use stat if i/o-extensions is featured.
- (try-module-autoload module-name): use file-exists? before
- file-is-directory?
-
-Sat Oct 5 18:54:03 1996 Mikael Djurfeldt <mdj@kenneth>
-
- * boot-9.scm: Added conditional loading of threads.scm.
-
- * threads.scm: New file. Modified from the Cygnus-r0.3
- distribution.
-
- * boot-9.scm (error-catching-loop): Added handling of key
- `switch-repl'.
-
- * boot-9.scm: Name change %%bad-throw --> bad-throw.
-
-Wed Oct 2 23:38:44 1996 Jim Blandy <jimb@totoro.cyclic.com>
-
- * boot-9.scm (make-record-type, record-constructor): Don't assume
- the empty list is false when parsing the argument list.
-
-Mon Sep 30 22:15:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
-
- * boot-9.scm (signal-handler): Clean up logic.
-
- * boot-9.scm (load): Assume %load-path is always bound.
-
-Sat Sep 28 00:15:37 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm (error): replace another throw with scm-error. Throw
- to 'misc-error instead of 'error (no need to distinguish these.)
- Don't set up 'error as a key.
- Set up regex-error as a key, if regex is available.
- (signal-handler): use scm-error, not throw.
-
-* (%try-load, try-load-with-path, %load, load-with-path,
- basic-try-load-with-path, basic-load-with-path,
- try-load-module-with-path,load-module-with-path): deleted, since
- they seem redundant.
- (try-load): define using %try-load, not try-load-with-path.
-* (load): rewritten. load tries to open the file directly and
- with a .scm extension before searching the library directories
- (should "." be added to %load-path? then load could still open
- directly files starting with "/").
- (try-module-autoload): use load, not load-with-path.
- (%load-indent): deleted, -2 was causing errors.
-
- (%read-sharp): use port-line, not line-number.
-
-Fri Sep 27 16:23:51 1996 Jim Blandy <jimb@totoro.cyclic.com>
-
- * boot-9.scm (%%bad-throw): Delete definition. 1) It's very
- straightforward to provide the equivalent functionality using
- (catch #t ...), so there's no need for the extra complexity. 2)
- Outside the context of a read-eval-print loop (which Guile should
- not require) it's not clear we should do anything more complicated
- than print an error and exit; the user or REPL can establish
- something better if it wants. 3) In that case, it's much more
- robust to just do it in the C code.
-
-Tue Sep 24 06:53:04 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm (%try-load): define using primitive-load. Previously
- %try-load itself was the primitive.
- (load-with-path): use scm-error instead of %load-announce-lossage.
- Errors are thrown to 'misc-error instead of 'could-not-load.
- (%load-announce-lossage): deleted.
-
-Mon Sep 23 00:16:31 1996 Mikael Djurfeldt <mdj@kenneth>
-
- * boot-9.scm (warn, scm-style-repl): Use C printer instead of `print'.
- (make-record-type type-name fields): Temporarily remove support
- for printing of records (not possible yet with C printer).
-
-Fri Sep 20 00:24:27 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm (file-exists?, file-is-directory): catch only
- system-error, not every kind of error.
- (scm-error): new procedure.
-
-Thu Sep 19 16:02:46 1996 Jim Blandy <jimb@totoro.cyclic.com>
-
- * boot-9.scm: Formatting tweaks.
-
-Wed Sep 18 09:07:37 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm (%%handle-system-error key): remove the code for
- SCM-style errors. handle the case that an unexpected number
- of args are supplied.
- (%%system-errors): removed.
- (error): redefine using a throw with key and 4 args.
- ('error): associate 'error, 'error-signal keys with
- %%handle-system-error.
- (%%default-error-handler): removed.
- (signal-handler): throw with 4 args and use the error-signal key.
- Create an error message instead of using numerical codes.
- (%%bad-throw): call error instead of throw if key not found.
-
-Tue Sep 17 04:11:28 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm: initialize new error keys (see libguile/ChangeLog).
- (%%handle-system-error key): check subr is not #f before printing.
- Recognize %s (embed an argument using "display") and
- %S (embed an argument using "write").
-
-Sun Sep 15 03:55:35 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm (%%handle-system-error key): set args and rest to
- the empty list if they are #f.
- Initialize out-of-range as an error key.
-
-Sat Sep 14 03:41:15 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * PLUGIN/REQ: remove the "ice-9 lgh" line which causes a cycle.
-
- * boot-9.scm: remove leading %% from references to '%%system-error.
- (%%handle-system-error): don't pass all the thrown arguments when
- aborting, just the key and subr.
- Remove the code to "Install default handlers for built-in errors."
- Remove the definition of the syserror procedure.
- Associate 'numerical-overflow with default handler.
-
-Fri Sep 13 04:58:11 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
-
- * boot-9.scm: Name change: value-ref --> local-ref
- resolved-ref --> nested-ref Motivation: conformance to the other
- dictionary operators: list-ref operates on list, vector-ref
- operates on vector, nested-ref operates on nested namespace,
- local-ref operates on the local nested namespace.
-
-Sat Sep 7 06:44:47 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm (%%handle-system-error): recognise errors thrown
- by lgh-error (fill-message etc.)
- (fill-message): check first whether args is null.
- (fill-message): bug fix and check that args is a list.
-
-Thu Sep 5 11:33:41 1996 Jim Blandy <jimb@floss.cyclic.com>
-
- * boot-9.scm: %load-path is initialized in C code now.
- (implementation-vicinity, parse-path): Deleted, along with code to
- initialize %load-path.
-
- * boot-9.scm (in-vicinity): If the vicinity doesn't end with a
- "/", use one to separate it from the file.
-
-Thu Aug 29 23:05:11 1996 Thomas Morgan <tmorgan@gnu.ai.mit.edu>
-
- * boot-9.scm (%load-path): Add the site directory.
- Add the directory named after the version number.
- Prepend the version number to the other directories in the path.
- Simplify by mapping the common prefix onto each item.
- * Makefile.in (datadir, pkgdatadir, pkgverdatadir, subpkgdatadir,
- sitedatadir): New definitions.
- (libparent, libdir, install_path): Replaced by above.
- (install): Create the above directories.
- Put the source files into subpkgdatadir.
- (uninstall): Remove the above directories.
-
-Thu Aug 29 21:48:47 1996 Jim Blandy <jimb@floss.cyclic.com>
-
- Don't use the PLUGIN system to gather information for the
- Makefile's distribution and installation targets; just put it all
- in the Makefile directly.
- * PLUGIN/this.configure (scm_files, aux_files): Remove sections
- for these.
- * configure.in: Remove code that gets and substitutes scm_files and
- aux_files.
- * Makefile.in (scm_files, aux_files): Write out the list of files
- here, where people expect to find them.
-
-Fri Aug 23 06:44:36 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
-
- * boot-9.scm: Preliminary solution: optionally load the debug
- module. Changed "gls" to "guile1.0b3".
-
- * debug.scm: New file: debug extensions.
-
-Wed Aug 21 13:06:56 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
-
- * boot-9.scm (print-vector): Renamed weak-hash-table? -->
- weak-key-hash-table?. (Again!)
-
-Tue Aug 20 07:31:39 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
-
- * boot-9.scm (print-vector, macro-table, xformer-table):
- Renamed weak-hash-table --> weak-key-hash-table.
-
- * poe.scm (funcq-memo): Renamed weak-hash-table -->
- weak-key-hash-table.
-
-Sat Aug 3 06:16:35 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm (*null-device*): global constant from goonix.
- (move->fdes): adjusted for boolean primitive-move->fdes. return
- the modified port, always set revealed count to 1 (SCSH compatible).
- (release-port-handle port): from goonix (SCSH compatible).
- (%open-file): removed.
- (open-input-file, open-output-file, file-exists?, file-is-directory?):
- modified for open-file change (does not return #f).
-
-Thu Aug 1 02:52:42 1996 Jim Blandy <jimb@totoro.cyclic.com>
-
- * Makefile.in (dist-dir): New target for new dist system.
- (manifest): Deleted.
- * PLUGIN/this.configure (aux_files): Removed PLUGIN; it's a
- directory, and needs special treatment in the dist-dir target.
-
-Thu Aug 1 09:00:21 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm: remove the wrappers for '%' system primitives,
- now that they throw errors directly.
- remove make-simple-wrapper and similar functions.
- protect a call to getenv which may now throw an exception.
-
-Wed Jul 31 23:44:42 1996 Gary Houston <ghouston@actrix.gen.nz>
-
- * boot-9.scm (false-if-exception): new macro.
-
-Fri Apr 19 13:53:08 1996 Tom Lord <lord@beehive>
-
- * The more things change...
-
-
diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am
deleted file mode 100644
index 1647cffcc..000000000
--- a/ice-9/Makefile.am
+++ /dev/null
@@ -1,10 +0,0 @@
-## Process this file with automake to produce Makefile.in.
-
-AUTOMAKE_OPTIONS = foreign
-
-subpkgdatadir = $(pkgdatadir)/$(VERSION)/@module@
-subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
-mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm
-
-## test.scm is not currently installed.
-EXTRA_DIST = PLUGIN/REQ $(subpkgdata_DATA) test.scm
diff --git a/ice-9/Makefile.in b/ice-9/Makefile.in
deleted file mode 100644
index 65600dba8..000000000
--- a/ice-9/Makefile.in
+++ /dev/null
@@ -1,207 +0,0 @@
-# Makefile.in generated automatically by automake 1.1l from Makefile.am
-
-# Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
-# This Makefile.in is free software; the Free Software Foundation
-# gives unlimited permission to copy, distribute and modify it.
-
-
-SHELL = /bin/sh
-
-srcdir = @srcdir@
-top_srcdir = @top_srcdir@
-VPATH = @srcdir@
-prefix = @prefix@
-exec_prefix = @exec_prefix@
-
-bindir = @bindir@
-sbindir = @sbindir@
-libexecdir = @libexecdir@
-datadir = @datadir@
-sysconfdir = @sysconfdir@
-sharedstatedir = @sharedstatedir@
-localstatedir = @localstatedir@
-libdir = @libdir@
-infodir = @infodir@
-mandir = @mandir@
-includedir = @includedir@
-oldincludedir = /usr/include
-
-pkgdatadir = $(datadir)/@PACKAGE@
-pkglibdir = $(libdir)/@PACKAGE@
-pkgincludedir = $(includedir)/@PACKAGE@
-
-top_builddir = .
-
-INSTALL = @INSTALL@
-INSTALL_PROGRAM = @INSTALL_PROGRAM@
-INSTALL_DATA = @INSTALL_DATA@
-INSTALL_SCRIPT = @INSTALL_SCRIPT@
-transform = @program_transform_name@
-VERSION = @VERSION@
-INSTALL_SCRIPT = @INSTALL_SCRIPT@
-module = @module@
-PACKAGE = @PACKAGE@
-
-AUTOMAKE_OPTIONS = foreign
-
-subpkgdatadir = $(pkgdatadir)/$(VERSION)/@module@
-subpkgdata_DATA = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
-mapping.scm poe.scm slib.scm tags.scm threads.scm r4rs.scm
-
-EXTRA_DIST = PLUGIN/REQ $(subpkgdata_DATA) test.scm
-ACLOCAL = $(top_srcdir)/aclocal.m4
-mkinstalldirs = $(SHELL) $(top_srcdir)/../mkinstalldirs
-CONFIG_CLEAN_FILES =
-DATA = $(subpkgdata_DATA)
-
-DIST_COMMON = COPYING ChangeLog Makefile.am Makefile.in aclocal.m4 \
-configure configure.in
-
-
-DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \
- $(TEXINFOS) $(MANS) $(EXTRA_DIST)
-
-TAR = tar
-default: all
-
-.SUFFIXES:
-$(srcdir)/Makefile.in: Makefile.am $(top_srcdir)/configure.in $(ACLOCAL)
- cd $(top_srcdir) && automake --foreign Makefile
-
-Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status $(BUILT_SOURCES)
- cd $(top_builddir) \
- && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
-
-$(srcdir)/aclocal.m4: configure.in
- cd $(srcdir) && aclocal
-
-config.status: configure
- $(SHELL) ./config.status --recheck
-$(srcdir)/configure: configure.in $(ACLOCAL) $(CONFIGURE_DEPENDENCIES)
- cd $(srcdir) && autoconf
-
-install-subpkgdataDATA: $(subpkgdata_DATA)
- $(NORMAL_INSTALL)
- $(mkinstalldirs) $(subpkgdatadir)
- @list="$(subpkgdata_DATA)"; for p in $$list; do \
- if test -f $(srcdir)/$$p; then \
- echo "$(INSTALL_DATA) $(srcdir)/$$p $(subpkgdatadir)/$$p"; \
- $(INSTALL_DATA) $(srcdir)/$$p $(subpkgdatadir)/$$p; \
- else if test -f $$p; then \
- echo "$(INSTALL_DATA) $$p $(subpkgdatadir)/$$p"; \
- $(INSTALL_DATA) $$p $(subpkgdatadir)/$$p; \
- fi; fi; \
- done
-
-uninstall-subpkgdataDATA:
- list="$(subpkgdata_DATA)"; for p in $$list; do \
- rm -f $(subpkgdatadir)/$$p; \
- done
-tags: TAGS
-TAGS:
-
-
-distdir = $(PACKAGE)-$(VERSION)
-# This target untars the dist file and tries a VPATH configuration. Then
-# it guarantees that the distribution is self-contained by making another
-# tarfile.
-distcheck: dist
- rm -rf $(distdir)
- $(TAR) zxf $(distdir).tar.gz
- mkdir $(distdir)/=build
- mkdir $(distdir)/=inst
- dc_install_base=`cd $(distdir)/=inst && pwd`; \
- cd $(distdir)/=build \
- && ../configure --srcdir=.. --prefix=$$dc_install_base \
- && $(MAKE) \
- && $(MAKE) dvi \
- && $(MAKE) check \
- && $(MAKE) install \
- && $(MAKE) installcheck \
- && $(MAKE) dist
- rm -rf $(distdir)
- @echo "========================"; \
- echo "$(distdir).tar.gz is ready for distribution"; \
- echo "========================"
-dist: distdir
- -chmod -R a+r $(distdir)
- $(TAR) chozf $(distdir).tar.gz $(distdir)
- rm -rf $(distdir)
-dist-all: distdir
- -chmod -R a+r $(distdir)
- $(TAR) chozf $(distdir).tar.gz $(distdir)
- rm -rf $(distdir)
-distdir: $(DISTFILES)
- rm -rf $(distdir)
- mkdir $(distdir)
- -chmod 755 $(distdir)
- here=`pwd`; distdir=`cd $(distdir) && pwd` \
- && cd $(srcdir) \
- && automake --include-deps --build-dir=$$here --srcdir-name=$(srcdir) --output-dir=$$distdir --foreign
- $(mkinstalldirs) $(distdir)/PLUGIN
- @for file in $(DISTFILES); do \
- d=$(srcdir); \
- test -f $(distdir)/$$file \
- || ln $$d/$$file $(distdir)/$$file 2> /dev/null \
- || cp -p $$d/$$file $(distdir)/$$file; \
- done
-info:
-dvi:
-check: all
- $(MAKE)
-installcheck:
-install-exec:
- $(NORMAL_INSTALL)
-
-install-data: install-subpkgdataDATA
- $(NORMAL_INSTALL)
-
-install: install-exec install-data all
- @:
-
-uninstall: uninstall-subpkgdataDATA
-
-all: $(DATA) Makefile
-
-install-strip:
- $(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
-installdirs:
- $(mkinstalldirs) $(subpkgdatadir)
-
-
-mostlyclean-generic:
- test -z "$(MOSTLYCLEANFILES)" || rm -f $(MOSTLYCLEANFILES)
-
-clean-generic:
- test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
-
-distclean-generic:
- rm -f Makefile $(DISTCLEANFILES)
- rm -f config.cache config.log stamp-h
- test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
-
-maintainer-clean-generic:
- test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
- test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES)
-mostlyclean: mostlyclean-generic
-
-clean: clean-generic mostlyclean
-
-distclean: distclean-generic clean
- rm -f config.status
-
-maintainer-clean: maintainer-clean-generic distclean
- @echo "This command is intended for maintainers to use;"
- @echo "it deletes files that may require special tools to rebuild."
- rm -f config.status
-
-.PHONY: default uninstall-subpkgdataDATA install-subpkgdataDATA tags \
-distdir info dvi installcheck install-exec install-data install \
-uninstall all installdirs mostlyclean-generic distclean-generic \
-clean-generic maintainer-clean-generic clean mostlyclean distclean \
-maintainer-clean
-
-
-# Tell versions [3.59,3.63) of GNU make to not export all variables.
-# Otherwise a system limit (for SysV at least) may be exceeded.
-.NOEXPORT:
diff --git a/ice-9/aclocal.m4 b/ice-9/aclocal.m4
deleted file mode 100644
index ace866913..000000000
--- a/ice-9/aclocal.m4
+++ /dev/null
@@ -1,64 +0,0 @@
-dnl aclocal.m4 generated automatically by aclocal 1.1l
-
-
-dnl Usage: AM_INIT_GUILE_MODULE(module-name)
-dnl This macro will automatically get the guile version from the
-dnl top-level srcdir, and will initialize automake. It also
-dnl defines the `module' variable.
-AC_DEFUN([AM_INIT_GUILE_MODULE],[
-. $srcdir/../GUILE-VERSION
-AM_INIT_AUTOMAKE($PACKAGE, $VERSION)
-AC_CONFIG_AUX_DIR(..)
-module=[$1]
-AC_SUBST(module)])
-
-# Do all the work for Automake. This macro actually does too much --
-# some checks are only needed if your package does certain things.
-# But this isn't really a big deal.
-
-# serial 1
-
-dnl Usage:
-dnl AM_INIT_AUTOMAKE(package,version)
-
-AC_DEFUN(AM_INIT_AUTOMAKE,
-[AC_REQUIRE([AM_PROG_INSTALL])
-PACKAGE=[$1]
-AC_SUBST(PACKAGE)
-AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE")
-VERSION=[$2]
-AC_SUBST(VERSION)
-AC_DEFINE_UNQUOTED(VERSION, "$VERSION")
-AM_SANITY_CHECK
-AC_ARG_PROGRAM
-AC_PROG_MAKE_SET])
-
-
-# serial 1
-
-AC_DEFUN(AM_PROG_INSTALL,
-[AC_REQUIRE([AC_PROG_INSTALL])
-test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
-AC_SUBST(INSTALL_SCRIPT)dnl
-])
-
-#
-# Check to make sure that the build environment is sane.
-#
-
-AC_DEFUN(AM_SANITY_CHECK,
-[AC_MSG_CHECKING([whether build environment is sane])
-echo timestamp > conftestfile
-# Do this in a subshell so we don't clobber the current shell's
-# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test?
-if (set X `ls -t $srcdir/configure conftestfile`; test "[$]2" = conftestfile)
-then
- # Ok.
- :
-else
- AC_MSG_ERROR([newly created file is older than distributed files!
-Check your system clock])
-fi
-rm -f conftest*
-AC_MSG_RESULT(yes)])
-
diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
deleted file mode 100644
index 9a5426bdc..000000000
--- a/ice-9/boot-9.scm
+++ /dev/null
@@ -1,3479 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-;;; This file is the first thing loaded into Guile. It adds many mundane
-;;; definitions and a few that are interesting.
-;;;
-;;; The module system (hence the hierarchical namespace) are defined in this
-;;; file.
-;;;
-
-
-;;; During Guile development, we want to use debugging evaluator and record
-;;; positions of source expressions in boot-9.scm by default.
-
-(debug-options-interface (cons 'debug (debug-options-interface)))
-(read-options-interface (cons 'positions (read-options-interface)))
-
-
-;;; {Features}
-;;
-
-(define (provide sym)
- (if (not (memq sym *features*))
- (set! *features* (cons sym *features*))))
-
-
-;;; {R4RS compliance}
-
-(primitive-load-path "ice-9/r4rs.scm")
-
-
-;;; {Simple Debugging Tools}
-;;
-
-
-;; peek takes any number of arguments, writes them to the
-;; current ouput port, and returns the last argument.
-;; It is handy to wrap around an expression to look at
-;; a value each time is evaluated, e.g.:
-;;
-;; (+ 10 (troublesome-fn))
-;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
-;;
-
-(define (peek . stuff)
- (newline)
- (display ";;; ")
- (write stuff)
- (newline)
- (car (last-pair stuff)))
-
-(define pk peek)
-
-(define (warn . stuff)
- (with-output-to-port (current-error-port)
- (lambda ()
- (newline)
- (display ";;; WARNING ")
- (display stuff)
- (newline)
- (car (last-pair stuff)))))
-
-
-;;; {apply and call-with-current-continuation}
-;;;
-;;; These turn syntax, @apply and @call-with-current-continuation,
-;;; into procedures.
-;;;
-
-(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
-(define (call-with-current-continuation proc)
- (@call-with-current-continuation proc))
-
-
-
-;;; {Trivial Functions}
-;;;
-
-(define (id x) x)
-(define (1+ n) (+ n 1))
-(define (-1+ n) (+ n -1))
-(define 1- -1+)
-(define return-it noop)
-(define (and=> value thunk) (and value (thunk value)))
-(define (make-hash-table k) (make-vector k '()))
-
-;;; apply-to-args is functionally redunant with apply and, worse,
-;;; is less general than apply since it only takes two arguments.
-;;;
-;;; On the other hand, apply-to-args is a syntacticly convenient way to
-;;; perform binding in many circumstances when the "let" family of
-;;; of forms don't cut it. E.g.:
-;;;
-;;; (apply-to-args (return-3d-mouse-coords)
-;;; (lambda (x y z)
-;;; ...))
-;;;
-
-(define (apply-to-args args fn) (apply fn args))
-
-
-;;; {Integer Math}
-;;;
-
-(define (ipow-by-squaring x k acc proc)
- (cond ((zero? k) acc)
- ((= 1 k) (proc acc x))
- (else (logical:ipow-by-squaring (proc x x)
- (quotient k 2)
- (if (even? k) acc (proc acc x))
- proc))))
-
-(define string-character-length string-length)
-
-
-
-;; A convenience function for combining flag bits. Like logior, but
-;; handles the cases of 0 and 1 arguments.
-;;
-(define (flags . args)
- (cond
- ((null? args) 0)
- ((null? (cdr args)) (car args))
- (else (apply logior args))))
-
-
-;;; {Symbol Properties}
-;;;
-
-(define (symbol-property sym prop)
- (let ((pair (assoc prop (symbol-pref sym))))
- (and pair (cdr pair))))
-
-(define (set-symbol-property! sym prop val)
- (let ((pair (assoc prop (symbol-pref sym))))
- (if pair
- (set-cdr! pair val)
- (symbol-pset! sym (acons prop val (symbol-pref sym))))))
-
-(define (symbol-property-remove! sym prop)
- (let ((pair (assoc prop (symbol-pref sym))))
- (if pair
- (symbol-pset! sym (delq! pair (symbol-pref sym))))))
-
-
-;;; {Arrays}
-;;;
-
-(begin
- (define uniform-vector? array?)
- (define make-uniform-vector dimensions->uniform-array)
- ; (define uniform-vector-ref array-ref)
- (define (uniform-vector-set! u i o)
- (uniform-vector-set1! u o i))
- (define uniform-vector-fill! array-fill!)
- (define uniform-vector-read! uniform-array-read!)
- (define uniform-vector-write uniform-array-write)
-
- (define (make-array fill . args)
- (dimensions->uniform-array args () fill))
- (define (make-uniform-array prot . args)
- (dimensions->uniform-array args prot))
- (define (list->array ndim lst)
- (list->uniform-array ndim '() lst))
- (define (list->uniform-vector prot lst)
- (list->uniform-array 1 prot lst))
- (define (array-shape a)
- (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
- (array-dimensions a))))
-
-
-;;; {Keywords}
-;;;
-
-(define (symbol->keyword symbol)
- (make-keyword-from-dash-symbol (symbol-append '- symbol)))
-
-(define (keyword->symbol kw)
- (let ((sym (keyword-dash-symbol kw)))
- (string->symbol (substring sym 1 (length sym)))))
-
-(define (kw-arg-ref args kw)
- (let ((rem (member kw args)))
- (and rem (pair? (cdr rem)) (cadr rem))))
-
-
-;;; {Print}
-;;; MDJ 960919 <djurfeldt@nada.kth.se>: This code will probably be
-;;; removed before the first release of Guile. Later releases may
-;;; contain more fancy printing code.
-
-(define (print obj . args)
- (let ((default-args (list (current-output-port) 0 0 default-print-style #f)))
- (apply-to-args (append args (list-cdr-ref default-args (length args)))
- (lambda (port depth length style table)
- (cond
- ((and table (print-table-ref table obj))
- ((print-style-tag-hook style 'eq-val)
- obj port depth length style table))
- (else
- (and table (print-table-add! table obj))
- (cond
- ((print-style-max-depth? style depth)
- ((print-style-excess-depth-hook style)))
- ((print-style-max-length? style length)
- ((print-style-excess-length-hook style)))
- (else
- ((print-style-hook style obj)
- obj port depth length style table)))))))))
-
-(define (make-print-style) (make-vector 59 '()))
-
-(define (extend-print-style! style utag printer)
- (hashq-set! style utag printer))
-
-(define (print-style-hook style obj)
- (let ((type-tag (tag obj)))
- (or (hashq-ref style type-tag)
- (hashq-ref style (logand type-tag 255))
- print-obj)))
-
-(define (print-style-tag-hook style type-tag)
- (or (hashq-ref style type-tag)
- print-obj))
-
-(define (print-style-max-depth? style d) #f)
-(define (print-style-max-length? style l) #f)
-(define (print-style-excess-length-hook style)
- (hashq-ref style 'excess-length-hook))
-(define (print-style-excess-depth-hook style)
- (hashq-ref style 'excess-depth-hook))
-
-(define (make-print-table) (make-vector 59 '()))
-(define (print-table-ref table obj) (hashq-ref table obj))
-(define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref)))
-
-(define (print-obj obj port depth length style table) (write obj port))
-
-(define (print-pair pair port depth length style table)
- (if (= 0 length)
- (display #\( port))
-
- (print (car pair) port (+ 1 depth) 0 style table)
-
- (cond
- ((and (pair? (cdr pair))
- (or (not table)
- (not (print-table-ref table (cdr pair)))))
-
- (display #\space port)
- (print (cdr pair) port depth (+ 1 length) style table))
-
- ((null? (cdr pair)) (display #\) port))
-
- (else (display " . " port)
- (print (cdr pair) port (+ 1 depth) 0
- style table)
- (display #\) port))))
-
-(define (print-vector obj port depth length style table)
- (if (= 0 length)
- (cond
- ((weak-key-hash-table? obj) (display "#wh(" port))
- ((weak-value-hash-table? obj) (display "#whv(" port))
- ((doubly-weak-hash-table? obj) (display "#whd(" port))
- (else (display "#(" port))))
-
- (if (< length (vector-length obj))
- (print (vector-ref obj length) port (+ 1 depth) 0 style table))
-
- (cond
- ((>= (+ 1 length) (vector-length obj)) (display #\) port))
- (else (display #\space port)
- (print obj port depth
- (+ 1 length)
- style table))))
-
-(define default-print-style (make-print-style))
-
-(extend-print-style! default-print-style utag_vector print-vector)
-(extend-print-style! default-print-style utag_wvect print-vector)
-(extend-print-style! default-print-style utag_pair print-pair)
-(extend-print-style! default-print-style 'eq-val
- (lambda (obj port depth length style table)
- (if (symbol? obj)
- (display obj)
- (begin
- (display "##" port)
- (display (print-table-ref table obj))))))
-
-
-;;; {Records}
-;;;
-
-(define record-type-vtable (make-vtable-vtable "prpr" 0))
-
-(define (record-type? obj)
- (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
-
-(define (make-record-type type-name fields . opt)
- (let ((printer-fn (and (pair? opt) (car opt))))
- (let ((struct (make-struct record-type-vtable 0
- (make-struct-layout
- (apply symbol-append
- (map (lambda (f) "pw") fields)))
- type-name
- (copy-tree fields))))
- ;; !!! leaks printer functions
- ;; MDJ 960919 <djurfeldt@nada.kth.se>: *fixme* need to make it
- ;; possible to print records nicely.
- ;(if printer-fn
-; (extend-print-style! default-print-style
-; (logior utag_struct_base (ash (struct-vtable-tag struct) 8))
-; printer-fn))
- struct)))
-
-(define (record-type-name obj)
- (if (record-type? obj)
- (struct-ref obj struct-vtable-offset)
- (error 'not-a-record-type obj)))
-
-(define (record-type-fields obj)
- (if (record-type? obj)
- (struct-ref obj (+ 1 struct-vtable-offset))
- (error 'not-a-record-type obj)))
-
-(define (record-constructor rtd . opt)
- (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
- (eval `(lambda ,field-names
- (make-struct ',rtd 0 ,@(map (lambda (f)
- (if (memq f field-names)
- f
- #f))
- (record-type-fields rtd)))))))
-
-(define (record-predicate rtd)
- (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
-
-(define (record-accessor rtd field-name)
- (let* ((pos (list-index (record-type-fields rtd) field-name)))
- (if (not pos)
- (error 'no-such-field field-name))
- (eval `(lambda (obj)
- (and (eq? ',rtd (record-type-descriptor obj))
- (struct-ref obj ,pos))))))
-
-(define (record-modifier rtd field-name)
- (let* ((pos (list-index (record-type-fields rtd) field-name)))
- (if (not pos)
- (error 'no-such-field field-name))
- (eval `(lambda (obj val)
- (and (eq? ',rtd (record-type-descriptor obj))
- (struct-set! obj ,pos val))))))
-
-
-(define (record? obj)
- (and (struct? obj) (record-type? (struct-vtable obj))))
-
-(define (record-type-descriptor obj)
- (if (struct? obj)
- (struct-vtable obj)
- (error 'not-a-record obj)))
-
-(provide 'record)
-
-
-;;; {Booleans}
-;;;
-
-(define (->bool x) (not (not x)))
-
-
-;;; {Symbols}
-;;;
-
-(define (symbol-append . args)
- (string->symbol (apply string-append args)))
-
-(define (list->symbol . args)
- (string->symbol (apply list->string args)))
-
-(define (symbol . args)
- (string->symbol (apply string args)))
-
-(define (obarray-symbol-append ob . args)
- (string->obarray-symbol (apply string-append ob args)))
-
-(define obarray-gensym
- (let ((n -1))
- (lambda (obarray . opt)
- (if (null? opt)
- (set! opt '(%%gensym)))
- (let loop ((proposed-name (apply string-append opt)))
- (if (string->obarray-symbol obarray proposed-name #t)
- (loop (apply string-append (append opt (begin (set! n (1+ n)) (list (number->string n))))))
- (string->obarray-symbol obarray proposed-name))))))
-
-(define (gensym . args) (apply obarray-gensym #f args))
-
-
-;;; {Lists}
-;;;
-
-(define (list-index l k)
- (let loop ((n 0)
- (l l))
- (and (not (null? l))
- (if (eq? (car l) k)
- n
- (loop (+ n 1) (cdr l))))))
-
-(define (make-list n init)
- (let loop ((answer '())
- (n n))
- (if (<= n 0)
- answer
- (loop (cons init answer) (- n 1)))))
-
-
-
-;;; {and-map, or-map, and map-in-order}
-;;;
-;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
-;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
-;;; (map-in-order fn lst) is like (map fn lst) but definately in order of lst.
-;;;
-
-;; and-map f l
-;;
-;; Apply f to successive elements of l until exhaustion or f returns #f.
-;; If returning early, return #f. Otherwise, return the last value returned
-;; by f. If f has never been called because l is empty, return #t.
-;;
-(define (and-map f lst)
- (let loop ((result #t)
- (l lst))
- (and result
- (or (and (null? l)
- result)
- (loop (f (car l)) (cdr l))))))
-
-;; or-map f l
-;;
-;; Apply f to successive elements of l until exhaustion or while f returns #f.
-;; If returning early, return the return value of f.
-;;
-(define (or-map f lst)
- (let loop ((result #f)
- (l lst))
- (or result
- (and (not (null? l))
- (loop (f (car l)) (cdr l))))))
-
-;; map-in-order
-;;
-;; Like map, but guaranteed to process the list in order.
-;;
-(define (map-in-order fn l)
- (if (null? l)
- '()
- (cons (fn (car l))
- (map-in-order fn (cdr l)))))
-
-
-;;; {Files}
-;;; !!!! these should be implemented using Tcl commands, not fports.
-;;;
-
-(define (feature? feature)
- (and (memq feature *features*) #t))
-
-;; Using the vector returned by stat directly is probably not a good
-;; idea (it could just as well be a record). Hence some accessors.
-(define (stat:dev f) (vector-ref f 0))
-(define (stat:ino f) (vector-ref f 1))
-(define (stat:mode f) (vector-ref f 2))
-(define (stat:nlink f) (vector-ref f 3))
-(define (stat:uid f) (vector-ref f 4))
-(define (stat:gid f) (vector-ref f 5))
-(define (stat:rdev f) (vector-ref f 6))
-(define (stat:size f) (vector-ref f 7))
-(define (stat:atime f) (vector-ref f 8))
-(define (stat:mtime f) (vector-ref f 9))
-(define (stat:ctime f) (vector-ref f 10))
-(define (stat:blksize f) (vector-ref f 11))
-(define (stat:blocks f) (vector-ref f 12))
-
-;; derived from stat mode.
-(define (stat:type f) (vector-ref f 13))
-(define (stat:perms f) (vector-ref f 14))
-
-(define file-exists?
- (if (feature? 'posix)
- (lambda (str)
- (access? str F_OK))
- (lambda (str)
- (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
- (lambda args #f))))
- (if port (begin (close-port port) #t)
- #f)))))
-
-(define file-is-directory?
- (if (feature? 'i/o-extensions)
- (lambda (str)
- (eq? (stat:type (stat str)) 'directory))
- (lambda (str)
- (display str)
- (newline)
- (let ((port (catch 'system-error
- (lambda () (open-file (string-append str "/.")
- OPEN_READ))
- (lambda args #f))))
- (if port (begin (close-port port) #t)
- #f)))))
-
-(define (has-suffix? str suffix)
- (let ((sufl (string-length suffix))
- (sl (string-length str)))
- (and (> sl sufl)
- (string=? (substring str (- sl sufl) sl) suffix))))
-
-
-;;; {Error Handling}
-;;;
-
-(define (error . args)
- (save-stack)
- (if (null? args)
- (scm-error 'misc-error #f "?" #f #f)
- (let loop ((msg "%s")
- (rest (cdr args)))
- (if (not (null? rest))
- (loop (string-append msg " %S")
- (cdr rest))
- (scm-error 'misc-error #f msg args #f)))))
-
-(define (scm-error key subr message args rest)
- (throw key subr message args rest))
-
-;; bad-throw is the hook that is called upon a throw to a an unhandled
-;; key (unless the throw has four arguments, in which case
-;; it's usually interpreted as an error throw.)
-;; If the key has a default handler (a throw-handler-default property),
-;; it is applied to the throw.
-;;
-(define (bad-throw key . args)
- (let ((default (symbol-property key 'throw-handler-default)))
- (or (and default (apply default key args))
- (apply error "unhandled-exception:" key args))))
-
-;; mostly obsolete.
-;; A number of internally defined error types were represented
-;; as integers. Here is the mapping to symbolic names
-;; and error messages.
-;;
-;(define %%system-errors
-; '((-1 UNKNOWN "Unknown error")
-; (0 ARGn "Wrong type argument to ")
-; (1 ARG1 "Wrong type argument in position 1 to ")
-; (2 ARG2 "Wrong type argument in position 2 to ")
-; (3 ARG3 "Wrong type argument in position 3 to ")
-; (4 ARG4 "Wrong type argument in position 4 to ")
-; (5 ARG5 "Wrong type argument in position 5 to ")
-; (6 ARG5 "Wrong type argument in position 5 to ")
-; (7 ARG5 "Wrong type argument in position 5 to ")
-; (8 WNA "Wrong number of arguments to ")
-; (9 OVFLOW "Numerical overflow to ")
-; (10 OUTOFRANGE "Argument out of range to ")
-; (11 NALLOC "Could not allocate to ")
-; (12 STACK_OVFLOW "Stack overflow")
-; (13 EXIT "Exit (internal error?).")
-; (14 HUP_SIGNAL "hang-up")
-; (15 INT_SIGNAL "user interrupt")
-; (16 FPE_SIGNAL "arithmetic error")
-; (17 BUS_SIGNAL "bus error")
-; (18 SEGV_SIGNAL "segmentation violation")
-; (19 ALRM_SIGNAL "alarm")
-; (20 GC_SIGNAL "gc")
-; (21 TICK_SIGNAL "tick")))
-
-
-(define (timer-thunk) #t)
-(define (gc-thunk) #t)
-(define (alarm-thunk) #t)
-
-(define (signal-handler n)
- (let* (
- ;; these numbers are set in libguile, not the same as those
- ;; interned in posix.c for SIGSEGV etc.
- ;;
- (signal-messages `((14 . "hang-up")
- (15 . "user interrupt")
- (16 . "arithmetic error")
- (17 . "bus error")
- (18 . "segmentation violation"))))
- (cond
- ((= n 21) (unmask-signals) (timer-thunk))
- ((= n 20) (unmask-signals) (gc-thunk))
- ((= n 19) (unmask-signals) (alarm-thunk))
- (else (set! the-last-stack
- (make-stack #t
- (list-ref (list %hup-thunk
- %int-thunk
- %fpe-thunk
- %bus-thunk
- %segv-thunk)
- (- n 14))
- 1))
- (set! stack-saved? #t)
- (if (not (and (memq 'debug (debug-options-interface))
- (eq? (stack-id the-last-stack) 'repl-stack)))
- (set! the-last-stack #f))
- (unmask-signals)
- (let ((sig-pair (assoc n signal-messages)))
- (scm-error 'error-signal #f
- (cdr (or sig-pair
- (cons n "Unknown signal: %s")))
- (if sig-pair
- #f
- (list n))
- (list n)))))))
-
-
-;;; {Non-polymorphic versions of POSIX functions}
-
-(define (getgrnam name) (getgr name))
-(define (getgrgid id) (getgr id))
-(define (gethostbyaddr addr) (gethost addr))
-(define (gethostbyname name) (gethost name))
-(define (getnetbyaddr addr) (getnet addr))
-(define (getnetbyname name) (getnet name))
-(define (getprotobyname name) (getproto name))
-(define (getprotobynumber addr) (getproto addr))
-(define (getpwnam name) (getpw name))
-(define (getpwuid uid) (getpw uid))
-(define (getservbyname name proto) (%getserv name proto))
-(define (getservbyport port proto) (%getserv port proto))
-(define (endgrent) (setgr))
-(define (endhostent) (sethost))
-(define (endnetent) (setnet))
-(define (endprotoent) (setproto))
-(define (endpwent) (setpw))
-(define (endservent) (setserv))
-(define (file-position . args) (apply ftell args))
-(define (file-set-position . args) (apply fseek args))
-(define (getgrent) (getgr))
-(define (gethostent) (gethost))
-(define (getnetent) (getnet))
-(define (getprotoent) (getproto))
-(define (getpwent) (getpw))
-(define (getservent) (getserv))
-(define (reopen-file . args) (apply freopen args))
-(define (setgrent arg) (setgr arg))
-(define (sethostent arg) (sethost arg))
-(define (setnetent arg) (setnet arg))
-(define (setprotoent arg) (setproto arg))
-(define (setpwent arg) (setpw arg))
-(define (setservent arg) (setserv arg))
-
-(define (move->fdes port fd)
- (primitive-move->fdes port fd)
- (set-port-revealed! port 1)
- port)
-
-(define (release-port-handle port)
- (let ((revealed (port-revealed port)))
- (if (> revealed 0)
- (set-port-revealed! port (- revealed 1)))))
-
-
-;;; {Load Paths}
-;;;
-
-;;; Here for backward compatability
-;;
-(define scheme-file-suffix (lambda () ".scm"))
-
-(define (in-vicinity vicinity file)
- (let ((tail (let ((len (string-length vicinity)))
- (if (zero? len) #f
- (string-ref vicinity (- len 1))))))
- (string-append vicinity
- (if (eq? tail #\/) "" "/")
- file)))
-
-
-;;; {Loading by paths}
-
-;;; Load a Scheme source file named NAME, searching for it in the
-;;; directories listed in %load-path, and applying each of the file
-;;; name extensions listed in %load-extensions.
-(define (load-from-path name)
- (start-stack 'load-stack
- (primitive-load-path name #t read-sharp)))
-
-
-
-;;; {Transcendental Functions}
-;;;
-;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
-;;; Copyright (C) 1992, 1993 Jerry D. Hedden.
-;;; See the file `COPYING' for terms applying to this program.
-;;;
-
-(define (exp z)
- (if (real? z) ($exp z)
- (make-polar ($exp (real-part z)) (imag-part z))))
-
-(define (log z)
- (if (and (real? z) (>= z 0))
- ($log z)
- (make-rectangular ($log (magnitude z)) (angle z))))
-
-(define (sqrt z)
- (if (real? z)
- (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
- ($sqrt z))
- (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
-
-(define expt
- (let ((integer-expt integer-expt))
- (lambda (z1 z2)
- (cond ((exact? z2)
- (integer-expt z1 z2))
- ((and (real? z2) (real? z1) (>= z1 0))
- ($expt z1 z2))
- (else
- (exp (* z2 (log z1))))))))
-
-(define (sinh z)
- (if (real? z) ($sinh z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($sinh x) ($cos y))
- (* ($cosh x) ($sin y))))))
-(define (cosh z)
- (if (real? z) ($cosh z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($cosh x) ($cos y))
- (* ($sinh x) ($sin y))))))
-(define (tanh z)
- (if (real? z) ($tanh z)
- (let* ((x (* 2 (real-part z)))
- (y (* 2 (imag-part z)))
- (w (+ ($cosh x) ($cos y))))
- (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
-
-(define (asinh z)
- (if (real? z) ($asinh z)
- (log (+ z (sqrt (+ (* z z) 1))))))
-
-(define (acosh z)
- (if (and (real? z) (>= z 1))
- ($acosh z)
- (log (+ z (sqrt (- (* z z) 1))))))
-
-(define (atanh z)
- (if (and (real? z) (> z -1) (< z 1))
- ($atanh z)
- (/ (log (/ (+ 1 z) (- 1 z))) 2)))
-
-(define (sin z)
- (if (real? z) ($sin z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($sin x) ($cosh y))
- (* ($cos x) ($sinh y))))))
-(define (cos z)
- (if (real? z) ($cos z)
- (let ((x (real-part z)) (y (imag-part z)))
- (make-rectangular (* ($cos x) ($cosh y))
- (- (* ($sin x) ($sinh y)))))))
-(define (tan z)
- (if (real? z) ($tan z)
- (let* ((x (* 2 (real-part z)))
- (y (* 2 (imag-part z)))
- (w (+ ($cos x) ($cosh y))))
- (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
-
-(define (asin z)
- (if (and (real? z) (>= z -1) (<= z 1))
- ($asin z)
- (* -i (asinh (* +i z)))))
-
-(define (acos z)
- (if (and (real? z) (>= z -1) (<= z 1))
- ($acos z)
- (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
-
-(define (atan z . y)
- (if (null? y)
- (if (real? z) ($atan z)
- (/ (log (/ (- +i z) (+ +i z))) +2i))
- ($atan2 z (car y))))
-
-(set! abs magnitude)
-
-
-;;; {User Settable Hooks}
-;;;
-;;; Parts of the C code check the bindings of these variables.
-;;;
-
-(define ticks-interrupt #f)
-(define user-interrupt #f)
-(define alarm-interrupt #f)
-(define out-of-storage #f)
-(define could-not-open #f)
-(define end-of-program #f)
-(define hang-up #f)
-(define arithmetic-error #f)
-(define read-sharp #f)
-
-
-
-;;; {Reader Extensions}
-;;;
-
-;;; Reader code for various "#c" forms.
-;;;
-
-(define (parse-path-symbol s)
- (define (separate-fields-discarding-char ch str ret)
- (let loop ((fields '())
- (str str))
- (cond
- ((string-rindex str ch)
- => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 pos)) fields)
- (make-shared-substring str 0 pos))))
- (else (ret (cons str fields))))))
- (separate-fields-discarding-char #\/
- s
- (lambda (fields)
- (map string->symbol fields))))
-
-
-(define (%read-sharp c port)
- (define (barf)
- (error "unknown # object" c))
-
- (case c
- ((#\/) (let ((look (peek-char port)))
- (if (or (eof-object? look)
- (and (char? look)
- (or (char-whitespace? look)
- (string-index ")" look))))
- '()
- (parse-path-symbol (read port #t read-sharp)))))
- ((#\') (read port #t read-sharp))
- ((#\.) (eval (read port #t read-sharp)))
- ((#\b) (read:uniform-vector #t port))
- ((#\a) (read:uniform-vector #\a port))
- ((#\u) (read:uniform-vector 1 port))
- ((#\e) (read:uniform-vector -1 port))
- ((#\s) (read:uniform-vector 1.0 port))
- ((#\i) (read:uniform-vector 1/3 port))
- ((#\c) (read:uniform-vector 0+i port))
- ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
- (read:array c port))
- (else (barf))))
-
-(define (read:array digit port)
- (define chr0 (char->integer #\0))
- (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
- (if (char-numeric? (peek-char port))
- (readnum (+ (* 10 val)
- (- (char->integer (read-char port)) chr0)))
- val)))
- (prot (if (eq? #\( (peek-char port))
- '()
- (let ((c (read-char port)))
- (case c ((#\b) #t)
- ((#\a) #\a)
- ((#\u) 1)
- ((#\e) -1)
- ((#\s) 1.0)
- ((#\i) 1/3)
- ((#\c) 0+i)
- (else (error "read:array unknown option " c)))))))
- (if (eq? (peek-char port) #\()
- (list->uniform-array rank prot (read port #t read-sharp))
- (error "read:array list not found"))))
-
-(define (read:uniform-vector proto port)
- (if (eq? #\( (peek-char port))
- (list->uniform-array 1 proto (read port #t read-sharp))
- (error "read:uniform-vector list not found")))
-
-
-(define read-sharp (lambda a (apply %read-sharp a)))
-
-
-
-;;; {Dynamic Roots}
-;;;
-
-; mystery integers passed dynamic root error handlers
-(define repl-quit -1)
-(define repl-abort -2)
-
-
-
-;;; {Command Line Options}
-;;;
-
-(define (get-option argv kw-opts kw-args return)
- (cond
- ((null? argv)
- (return #f #f argv))
-
- ((or (not (eq? #\- (string-ref (car argv) 0)))
- (eq? (string-length (car argv)) 1))
- (return 'normal-arg (car argv) (cdr argv)))
-
- ((eq? #\- (string-ref (car argv) 1))
- (let* ((kw-arg-pos (or (string-index (car argv) #\=)
- (string-length (car argv))))
- (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
- (kw-opt? (member kw kw-opts))
- (kw-arg? (member kw kw-args))
- (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
- (substring (car argv)
- (+ kw-arg-pos 1)
- (string-length (car argv))))
- (and kw-arg?
- (begin (set! argv (cdr argv)) (car argv))))))
- (if (or kw-opt? kw-arg?)
- (return kw arg (cdr argv))
- (return 'usage-error kw (cdr argv)))))
-
- (else
- (let* ((char (substring (car argv) 1 2))
- (kw (symbol->keyword char)))
- (cond
-
- ((member kw kw-opts)
- (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
- (new-argv (if (= 0 (string-length rest-car))
- (cdr argv)
- (cons (string-append "-" rest-car) (cdr argv)))))
- (return kw #f new-argv)))
-
- ((member kw kw-args)
- (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
- (arg (if (= 0 (string-length rest-car))
- (cadr argv)
- rest-car))
- (new-argv (if (= 0 (string-length rest-car))
- (cddr argv)
- (cdr argv))))
- (return kw arg new-argv)))
-
- (else (return 'usage-error kw argv)))))))
-
-(define (for-next-option proc argv kw-opts kw-args)
- (let loop ((argv argv))
- (get-option argv kw-opts kw-args
- (lambda (opt opt-arg argv)
- (and opt (proc opt opt-arg argv loop))))))
-
-(define (display-usage-report kw-desc)
- (for-each
- (lambda (kw)
- (or (eq? (car kw) #t)
- (eq? (car kw) 'else)
- (let* ((opt-desc kw)
- (help (cadr opt-desc))
- (opts (car opt-desc))
- (opts-proper (if (string? (car opts)) (cdr opts) opts))
- (arg-name (if (string? (car opts))
- (string-append "<" (car opts) ">")
- ""))
- (left-part (string-append
- (with-output-to-string
- (lambda ()
- (map (lambda (x) (display (keyword-symbol x)) (display " "))
- opts-proper)))
- arg-name))
- (middle-part (if (and (< (length left-part) 30)
- (< (length help) 40))
- (make-string (- 30 (length left-part)) #\ )
- "\n\t")))
- (display left-part)
- (display middle-part)
- (display help)
- (newline))))
- kw-desc))
-
-
-
-(define (delq-all! obj l)
- (let ((answer (cons '() l)))
- (let loop ((pos answer))
- (cond
- ((null? (cdr pos)) (cdr answer))
- ((eq? (cadr pos) obj) (set-cdr! pos (cddr pos))
- (loop pos))
- (else (loop (cdr pos)))))))
-
-(define (transform-usage-lambda cases)
- (let* ((raw-usage (delq! 'else (map car cases)))
- (usage-sans-specials (map (lambda (x)
- (or (and (not (list? x)) x)
- (and (symbol? (car x)) #t)
- (and (boolean? (car x)) #t)
- x))
- raw-usage))
- (usage-desc (delq-all! #t usage-sans-specials))
- (kw-desc (map car usage-desc))
- (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
- (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
- (transmogrified-cases (map (lambda (case)
- (cons (let ((opts (car case)))
- (if (or (boolean? opts) (eq? 'else opts))
- opts
- (cond
- ((symbol? (car opts)) opts)
- ((boolean? (car opts)) opts)
- ((string? (caar opts)) (cdar opts))
- (else (car opts)))))
- (cdr case)))
- cases)))
- `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
- (lambda (%argv)
- (let %next-arg ((%argv %argv))
- (get-option %argv
- ',kw-opts
- ',kw-args
- (lambda (%opt %arg %new-argv)
- (case %opt
- ,@ transmogrified-cases))))))))
-
-
-
-
-;;; {Low Level Modules}
-;;;
-;;; These are the low level data structures for modules.
-;;;
-;;; !!! warning: The interface to lazy binder procedures is going
-;;; to be changed in an incompatible way to permit all the basic
-;;; module ops to be virtualized.
-;;;
-;;; (make-module size use-list lazy-binding-proc) => module
-;;; module-{obarray,uses,binder}[|-set!]
-;;; (module? obj) => [#t|#f]
-;;; (module-locally-bound? module symbol) => [#t|#f]
-;;; (module-bound? module symbol) => [#t|#f]
-;;; (module-symbol-locally-interned? module symbol) => [#t|#f]
-;;; (module-symbol-interned? module symbol) => [#t|#f]
-;;; (module-local-variable module symbol) => [#<variable ...> | #f]
-;;; (module-variable module symbol) => [#<variable ...> | #f]
-;;; (module-symbol-binding module symbol opt-value)
-;;; => [ <obj> | opt-value | an error occurs ]
-;;; (module-make-local-var! module symbol) => #<variable...>
-;;; (module-add! module symbol var) => unspecified
-;;; (module-remove! module symbol) => unspecified
-;;; (module-for-each proc module) => unspecified
-;;; (make-scm-module) => module ; a lazy copy of the symhash module
-;;; (set-current-module module) => unspecified
-;;; (current-module) => #<module...>
-;;;
-;;;
-
-
-;;; {Printing Modules}
-;; This is how modules are printed. You can re-define it.
-;;
-(define (%print-module mod port depth length style table)
- (display "#<" port)
- (display (or (module-kind mod) "module") port)
- (let ((name (module-name mod)))
- (if name
- (begin
- (display " " port)
- (display name port))))
- (display " " port)
- (display (number->string (object-address mod) 16) port)
- (display ">" port))
-
-;; module-type
-;;
-;; A module is characterized by an obarray in which local symbols
-;; are interned, a list of modules, "uses", from which non-local
-;; bindings can be inherited, and an optional lazy-binder which
-;; is a (CLOSURE module symbol) which, as a last resort, can provide
-;; bindings that would otherwise not be found locally in the module.
-;;
-(define module-type
- (make-record-type 'module '(obarray uses binder eval-closure name kind)
- %print-module))
-
-;; make-module &opt size uses binder
-;;
-;; Create a new module, perhaps with a particular size of obarray,
-;; initial uses list, or binding procedure.
-;;
-(define make-module
- (lambda args
-
- (define (parse-arg index default)
- (if (> (length args) index)
- (list-ref args index)
- default))
-
- (if (> (length args) 3)
- (error "Too many args to make-module." args))
-
- (let ((size (parse-arg 0 1021))
- (uses (parse-arg 1 '()))
- (binder (parse-arg 2 #f)))
-
- (if (not (integer? size))
- (error "Illegal size to make-module." size))
- (if (not (and (list? uses)
- (and-map module? uses)))
- (error "Incorrect use list." uses))
- (if (and binder (not (procedure? binder)))
- (error
- "Lazy-binder expected to be a procedure or #f." binder))
-
- (let ((module (module-constructor (make-vector size '())
- uses binder #f #f #f)))
-
- ;; We can't pass this as an argument to module-constructor,
- ;; because we need it to close over a pointer to the module
- ;; itself.
- (set-module-eval-closure! module
- (lambda (symbol define?)
- (if define?
- (module-make-local-var! module symbol)
- (module-variable module symbol))))
-
- module))))
-
-(define module-constructor (record-constructor module-type))
-(define module-obarray (record-accessor module-type 'obarray))
-(define set-module-obarray! (record-modifier module-type 'obarray))
-(define module-uses (record-accessor module-type 'uses))
-(define set-module-uses! (record-modifier module-type 'uses))
-(define module-binder (record-accessor module-type 'binder))
-(define set-module-binder! (record-modifier module-type 'binder))
-(define module-eval-closure (record-accessor module-type 'eval-closure))
-(define set-module-eval-closure! (record-modifier module-type 'eval-closure))
-(define module-name (record-accessor module-type 'name))
-(define set-module-name! (record-modifier module-type 'name))
-(define module-kind (record-accessor module-type 'kind))
-(define set-module-kind! (record-modifier module-type 'kind))
-(define module? (record-predicate module-type))
-
-
-(define (eval-in-module exp module)
- (eval2 exp (module-eval-closure module)))
-
-
-;;; {Module Searching in General}
-;;;
-;;; We sometimes want to look for properties of a symbol
-;;; just within the obarray of one module. If the property
-;;; holds, then it is said to hold ``locally'' as in, ``The symbol
-;;; DISPLAY is locally rebound in the module `safe-guile'.''
-;;;
-;;;
-;;; Other times, we want to test for a symbol property in the obarray
-;;; of M and, if it is not found there, try each of the modules in the
-;;; uses list of M. This is the normal way of testing for some
-;;; property, so we state these properties without qualification as
-;;; in: ``The symbol 'fnord is interned in module M because it is
-;;; interned locally in module M2 which is a member of the uses list
-;;; of M.''
-;;;
-
-;; module-search fn m
-;;
-;; return the first non-#f result of FN applied to M and then to
-;; the modules in the uses of m, and so on recursively. If all applications
-;; return #f, then so does this function.
-;;
-(define (module-search fn m v)
- (define (loop pos)
- (and (pair? pos)
- (or (module-search fn (car pos) v)
- (loop (cdr pos)))))
- (or (fn m v)
- (loop (module-uses m))))
-
-
-;;; {Is a symbol bound in a module?}
-;;;
-;;; Symbol S in Module M is bound if S is interned in M and if the binding
-;;; of S in M has been set to some well-defined value.
-;;;
-
-;; module-locally-bound? module symbol
-;;
-;; Is a symbol bound (interned and defined) locally in a given module?
-;;
-(define (module-locally-bound? m v)
- (let ((var (module-local-variable m v)))
- (and var
- (variable-bound? var))))
-
-;; module-bound? module symbol
-;;
-;; Is a symbol bound (interned and defined) anywhere in a given module
-;; or its uses?
-;;
-(define (module-bound? m v)
- (module-search module-locally-bound? m v))
-
-;;; {Is a symbol interned in a module?}
-;;;
-;;; Symbol S in Module M is interned if S occurs in
-;;; of S in M has been set to some well-defined value.
-;;;
-;;; It is possible to intern a symbol in a module without providing
-;;; an initial binding for the corresponding variable. This is done
-;;; with:
-;;; (module-add! module symbol (make-undefined-variable))
-;;;
-;;; In that case, the symbol is interned in the module, but not
-;;; bound there. The unbound symbol shadows any binding for that
-;;; symbol that might otherwise be inherited from a member of the uses list.
-;;;
-
-(define (module-obarray-get-handle ob key)
- ((if (symbol? key) hashq-get-handle hash-get-handle) ob key))
-
-(define (module-obarray-ref ob key)
- ((if (symbol? key) hashq-ref hash-ref) ob key))
-
-(define (module-obarray-set! ob key val)
- ((if (symbol? key) hashq-set! hash-set!) ob key val))
-
-(define (module-obarray-remove! ob key)
- ((if (symbol? key) hashq-remove! hash-remove!) ob key))
-
-;; module-symbol-locally-interned? module symbol
-;;
-;; is a symbol interned (not neccessarily defined) locally in a given module
-;; or its uses? Interned symbols shadow inherited bindings even if
-;; they are not themselves bound to a defined value.
-;;
-(define (module-symbol-locally-interned? m v)
- (not (not (module-obarray-get-handle (module-obarray m) v))))
-
-;; module-symbol-interned? module symbol
-;;
-;; is a symbol interned (not neccessarily defined) anywhere in a given module
-;; or its uses? Interned symbols shadow inherited bindings even if
-;; they are not themselves bound to a defined value.
-;;
-(define (module-symbol-interned? m v)
- (module-search module-symbol-locally-interned? m v))
-
-
-;;; {Mapping modules x symbols --> variables}
-;;;
-
-;; module-local-variable module symbol
-;; return the local variable associated with a MODULE and SYMBOL.
-;;
-;;; This function is very important. It is the only function that can
-;;; return a variable from a module other than the mutators that store
-;;; new variables in modules. Therefore, this function is the location
-;;; of the "lazy binder" hack.
-;;;
-;;; If symbol is defined in MODULE, and if the definition binds symbol
-;;; to a variable, return that variable object.
-;;;
-;;; If the symbols is not found at first, but the module has a lazy binder,
-;;; then try the binder.
-;;;
-;;; If the symbol is not found at all, return #f.
-;;;
-(define (module-local-variable m v)
-; (caddr
-; (list m v
- (let ((b (module-obarray-ref (module-obarray m) v)))
- (or (and (variable? b) b)
- (and (module-binder m)
- ((module-binder m) m v #f)))))
-;))
-
-;; module-variable module symbol
-;;
-;; like module-local-variable, except search the uses in the
-;; case V is not found in M.
-;;
-(define (module-variable m v)
- (module-search module-local-variable m v))
-
-
-;;; {Mapping modules x symbols --> bindings}
-;;;
-;;; These are similar to the mapping to variables, except that the
-;;; variable is dereferenced.
-;;;
-
-;; module-symbol-binding module symbol opt-value
-;;
-;; return the binding of a variable specified by name within
-;; a given module, signalling an error if the variable is unbound.
-;; If the OPT-VALUE is passed, then instead of signalling an error,
-;; return OPT-VALUE.
-;;
-(define (module-symbol-local-binding m v . opt-val)
- (let ((var (module-local-variable m v)))
- (if var
- (variable-ref var)
- (if (not (null? opt-val))
- (car opt-val)
- (error "Locally unbound variable." v)))))
-
-;; module-symbol-binding module symbol opt-value
-;;
-;; return the binding of a variable specified by name within
-;; a given module, signalling an error if the variable is unbound.
-;; If the OPT-VALUE is passed, then instead of signalling an error,
-;; return OPT-VALUE.
-;;
-(define (module-symbol-binding m v . opt-val)
- (let ((var (module-variable m v)))
- (if var
- (variable-ref var)
- (if (not (null? opt-val))
- (car opt-val)
- (error "Unbound variable." v)))))
-
-
-
-;;; {Adding Variables to Modules}
-;;;
-;;;
-
-
-;; module-make-local-var! module symbol
-;;
-;; ensure a variable for V in the local namespace of M.
-;; If no variable was already there, then create a new and uninitialzied
-;; variable.
-;;
-(define (module-make-local-var! m v)
- (or (let ((b (module-obarray-ref (module-obarray m) v)))
- (and (variable? b) b))
- (and (module-binder m)
- ((module-binder m) m v #t))
- (begin
- (let ((answer (make-undefined-variable v)))
- (module-obarray-set! (module-obarray m) v answer)
- answer))))
-
-;; module-add! module symbol var
-;;
-;; ensure a particular variable for V in the local namespace of M.
-;;
-(define (module-add! m v var)
- (if (not (variable? var))
- (error "Bad variable to module-add!" var))
- (module-obarray-set! (module-obarray m) v var))
-
-;; module-remove!
-;;
-;; make sure that a symbol is undefined in the local namespace of M.
-;;
-(define (module-remove! m v)
- (module-obarray-remove! (module-obarray m) v))
-
-(define (module-clear! m)
- (vector-fill! (module-obarray m) '()))
-
-;; MODULE-FOR-EACH -- exported
-;;
-;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
-;;
-(define (module-for-each proc module)
- (let ((obarray (module-obarray module)))
- (do ((index 0 (+ index 1))
- (end (vector-length obarray)))
- ((= index end))
- (for-each
- (lambda (bucket)
- (proc (car bucket) (cdr bucket)))
- (vector-ref obarray index)))))
-
-
-(define (module-map proc module)
- (let* ((obarray (module-obarray module))
- (end (vector-length obarray)))
-
- (let loop ((i 0)
- (answer '()))
- (if (= i end)
- answer
- (loop (+ 1 i)
- (append!
- (map (lambda (bucket)
- (proc (car bucket) (cdr bucket)))
- (vector-ref obarray i))
- answer))))))
-
-
-;;; {Low Level Bootstrapping}
-;;;
-
-;; make-root-module
-
-;; A root module uses the symhash table (the system's privileged
-;; obarray). Being inside a root module is like using SCM without
-;; any module system.
-;;
-
-
-(define (root-module-closure m s define?)
- (let ((bi (and (symbol-interned? #f s)
- (builtin-variable s))))
- (and bi
- (or define? (variable-bound? bi))
- (begin
- (module-add! m s bi)
- bi))))
-
-(define (make-root-module)
- (make-module 1019 '() root-module-closure))
-
-
-;; make-scm-module
-
-;; An scm module is a module into which the lazy binder copies
-;; variable bindings from the system symhash table. The mapping is
-;; one way only; newly introduced bindings in an scm module are not
-;; copied back into the system symhash table (and can be used to override
-;; bindings from the symhash table).
-;;
-
-(define (make-scm-module)
- (make-module 1019 '()
- (lambda (m s define?)
- (let ((bi (and (symbol-interned? #f s)
- (builtin-variable s))))
- (and bi
- (variable-bound? bi)
- (begin
- (module-add! m s bi)
- bi))))))
-
-
-
-
-;; the-module
-;;
-(define the-module #f)
-
-;; set-current-module module
-;;
-;; set the current module as viewed by the normalizer.
-;;
-(define (set-current-module m)
- (set! the-module m)
- (if m
- (set! *top-level-lookup-closure* (module-eval-closure the-module))
- (set! *top-level-lookup-closure* #f)))
-
-
-;; current-module
-;;
-;; return the current module as viewed by the normalizer.
-;;
-(define (current-module) the-module)
-
-;;; {Module-based Loading}
-;;;
-
-(define (save-module-excursion thunk)
- (let ((inner-module (current-module))
- (outer-module #f))
- (dynamic-wind (lambda ()
- (set! outer-module (current-module))
- (set-current-module inner-module)
- (set! inner-module #f))
- thunk
- (lambda ()
- (set! inner-module (current-module))
- (set-current-module outer-module)
- (set! outer-module #f)))))
-
-(define basic-load load)
-
-(define (load-module . args)
- (save-module-excursion (lambda () (apply basic-load args))))
-
-
-
-;;; {MODULE-REF -- exported}
-;;
-;; Returns the value of a variable called NAME in MODULE or any of its
-;; used modules. If there is no such variable, then if the optional third
-;; argument DEFAULT is present, it is returned; otherwise an error is signaled.
-;;
-(define (module-ref module name . rest)
- (let ((variable (module-variable module name)))
- (if (and variable (variable-bound? variable))
- (variable-ref variable)
- (if (null? rest)
- (error "No variable named" name 'in module)
- (car rest) ; default value
- ))))
-
-;; MODULE-SET! -- exported
-;;
-;; Sets the variable called NAME in MODULE (or in a module that MODULE uses)
-;; to VALUE; if there is no such variable, an error is signaled.
-;;
-(define (module-set! module name value)
- (let ((variable (module-variable module name)))
- (if variable
- (variable-set! variable value)
- (error "No variable named" name 'in module))))
-
-;; MODULE-DEFINE! -- exported
-;;
-;; Sets the variable called NAME in MODULE to VALUE; if there is no such
-;; variable, it is added first.
-;;
-(define (module-define! module name value)
- (let ((variable (module-local-variable module name)))
- (if variable
- (variable-set! variable value)
- (module-add! module name (make-variable value name)))))
-
-;; MODULE-USE! module interface
-;;
-;; Add INTERFACE to the list of interfaces used by MODULE.
-;;
-(define (module-use! module interface)
- (set-module-uses! module
- (cons interface (delq! interface (module-uses module)))))
-
-
-;;; {Recursive Namespaces}
-;;;
-;;;
-;;; A hierarchical namespace emerges if we consider some module to be
-;;; root, and variables bound to modules as nested namespaces.
-;;;
-;;; The routines in this file manage variable names in hierarchical namespace.
-;;; Each variable name is a list of elements, looked up in successively nested
-;;; modules.
-;;;
-;;; (nested-ref some-root-module '(foo bar baz))
-;;; => <value of a variable named baz in the module bound to bar in
-;;; the module bound to foo in some-root-module>
-;;;
-;;;
-;;; There are:
-;;;
-;;; ;; a-root is a module
-;;; ;; name is a list of symbols
-;;;
-;;; nested-ref a-root name
-;;; nested-set! a-root name val
-;;; nested-define! a-root name val
-;;; nested-remove! a-root name
-;;;
-;;;
-;;; (current-module) is a natural choice for a-root so for convenience there are
-;;; also:
-;;;
-;;; local-ref name == nested-ref (current-module) name
-;;; local-set! name val == nested-set! (current-module) name val
-;;; local-define! name val == nested-define! (current-module) name val
-;;; local-remove! name == nested-remove! (current-module) name
-;;;
-
-
-(define (nested-ref root names)
- (let loop ((cur root)
- (elts names))
- (cond
- ((null? elts) cur)
- ((not (module? cur)) #f)
- (else (loop (module-ref cur (car elts) #f) (cdr elts))))))
-
-(define (nested-set! root names val)
- (let loop ((cur root)
- (elts names))
- (if (null? (cdr elts))
- (module-set! cur (car elts) val)
- (loop (module-ref cur (car elts)) (cdr elts)))))
-
-(define (nested-define! root names val)
- (let loop ((cur root)
- (elts names))
- (if (null? (cdr elts))
- (module-define! cur (car elts) val)
- (loop (module-ref cur (car elts)) (cdr elts)))))
-
-(define (nested-remove! root names)
- (let loop ((cur root)
- (elts names))
- (if (null? (cdr elts))
- (module-remove! cur (car elts))
- (loop (module-ref cur (car elts)) (cdr elts)))))
-
-(define (local-ref names) (nested-ref (current-module) names))
-(define (local-set! names val) (nested-set! (current-module) names val))
-(define (local-define names val) (nested-define! (current-module) names val))
-(define (local-remove names) (nested-remove! (current-module) names))
-
-
-
-;;; {#/app}
-;;;
-;;; The root of conventionally named objects not directly in the top level.
-;;;
-;;; #/app/modules
-;;; #/app/modules/guile
-;;;
-;;; The directory of all modules and the standard root module.
-;;;
-
-(define (module-public-interface m) (module-ref m '%module-public-interface #f))
-(define (set-module-public-interface! m i) (module-define! m '%module-public-interface i))
-(define the-root-module (make-root-module))
-(define the-scm-module (make-scm-module))
-(set-module-public-interface! the-root-module the-scm-module)
-(set-module-name! the-root-module 'the-root-module)
-(set-module-name! the-scm-module 'the-scm-module)
-
-(set-current-module the-root-module)
-
-(define app (make-module 31))
-(local-define '(app modules) (make-module 31))
-(local-define '(app modules guile) the-root-module)
-
-;; (define-special-value '(app modules new-ws) (lambda () (make-scm-module)))
-
-(define (resolve-module name)
- (let ((full-name (append '(app modules) name)))
- (let ((already (local-ref full-name)))
- (or already
- (begin
- (try-module-autoload name)
- (make-modules-in (current-module) full-name))))))
-
-(define (beautify-user-module! module)
- (if (not (module-public-interface module))
- (let ((interface (make-module 31)))
- (set-module-name! interface (module-name module))
- (set-module-kind! interface 'interface)
- (set-module-public-interface! module interface)))
- (if (not (memq the-scm-module (module-uses module)))
- (set-module-uses! module (append (module-uses module) (list the-scm-module)))))
-
-(define (make-modules-in module name)
- (if (null? name)
- module
- (cond
- ((module-ref module (car name) #f) => (lambda (m) (make-modules-in m (cdr name))))
- (else (let ((m (make-module 31)))
- (set-module-kind! m 'directory)
- (set-module-name! m (car name))
- (module-define! module (car name) m)
- (make-modules-in m (cdr name)))))))
-
-(define (resolve-interface name)
- (let ((module (resolve-module name)))
- (and module (module-public-interface module))))
-
-
-(define %autoloader-developer-mode #t)
-
-(define (process-define-module args)
- (let* ((module-id (car args))
- (module (resolve-module module-id))
- (kws (cdr args)))
- (beautify-user-module! module)
- (let loop ((kws kws))
- (and (not (null? kws))
- (case (car kws)
- ((:use-module)
- (if (not (pair? (cdr kws)))
- (error "unrecognized defmodule argument" kws))
- (let* ((used-name (cadr kws))
- (used-module (resolve-module used-name)))
- (if (not (module-ref used-module '%module-public-interface #f))
- (begin
- ((if %autoloader-developer-mode warn error) "no code for module" used-module)
- (beautify-user-module! used-module)))
- (let ((interface (module-ref used-module '%module-public-interface #f)))
- (if (not interface)
- (error "missing interface for use-module" used-module))
- (set-module-uses! module
- (append! (delq! interface (module-uses module))
- (list interface)))))
- (loop (cddr kws)))
-
- (else (error "unrecognized defmodule argument" kws)))))
- module))
-
-;;; {Autoloading modules}
-
-(define autoloads-in-progress '())
-
-(define (try-module-autoload module-name)
-
- (define (sfx name) (string-append name (scheme-file-suffix)))
- (let* ((reverse-name (reverse module-name))
- (name (car reverse-name))
- (dir-hint-module-name (reverse (cdr reverse-name)))
- (dir-hint (apply symbol-append (map (lambda (elt) (symbol-append elt "/")) dir-hint-module-name))))
- (resolve-module dir-hint-module-name)
- (and (not (autoload-done-or-in-progress? dir-hint name))
- (let ((didit #f))
- (dynamic-wind
- (lambda () (autoload-in-progress! dir-hint name))
- (lambda ()
- (let loop ((dirs %load-path))
- (and (not (null? dirs))
- (or
- (let ((d (car dirs))
- (trys (list
- dir-hint
- (sfx dir-hint)
- (in-vicinity dir-hint name)
- (in-vicinity dir-hint (sfx name)))))
- (and (or-map (lambda (f)
- (let ((full (in-vicinity d f)))
- full
- (and (file-exists? full)
- (not (file-is-directory? full))
- (begin
- (save-module-excursion
- (lambda ()
- (load (string-append
- d "/" f))))
- #t))))
- trys)
- (begin
- (set! didit #t)
- #t)))
- (loop (cdr dirs))))))
- (lambda () (set-autoloaded! dir-hint name didit)))
- didit))))
-
-(define autoloads-done '((guile . guile)))
-
-(define (autoload-done-or-in-progress? p m)
- (let ((n (cons p m)))
- (->bool (or (member n autoloads-done)
- (member n autoloads-in-progress)))))
-
-(define (autoload-done! p m)
- (let ((n (cons p m)))
- (set! autoloads-in-progress
- (delete! n autoloads-in-progress))
- (or (member n autoloads-done)
- (set! autoloads-done (cons n autoloads-done)))))
-
-(define (autoload-in-progress! p m)
- (let ((n (cons p m)))
- (set! autoloads-done
- (delete! n autoloads-done))
- (set! autoloads-in-progress (cons n autoloads-in-progress))))
-
-(define (set-autoloaded! p m done?)
- (if done?
- (autoload-done! p m)
- (let ((n (cons p m)))
- (set! autoloads-done (delete! n autoloads-done))
- (set! autoloads-in-progress (delete! n autoloads-in-progress)))))
-
-
-
-
-
-;;; {Macros}
-;;;
-
-(define macro-table (make-weak-key-hash-table 523))
-(define xformer-table (make-weak-key-hash-table 523))
-
-(define (defmacro? m) (hashq-ref macro-table m))
-(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
-(define (defmacro-transformer m) (hashq-ref xformer-table m))
-(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
-
-(define defmacro:transformer
- (lambda (f)
- (let* ((xform (lambda (exp env)
- (copy-tree (apply f (cdr exp)))))
- (a (procedure->memoizing-macro xform)))
- (assert-defmacro?! a)
- (set-defmacro-transformer! a f)
- a)))
-
-
-(define defmacro
- (let ((defmacro-transformer
- (lambda (name parms . body)
- (let ((transformer `(lambda ,parms ,@body)))
- `(define ,name
- (,(lambda (transformer)
- (defmacro:transformer transformer))
- ,transformer))))))
- (defmacro:transformer defmacro-transformer)))
-
-(define defmacro:syntax-transformer
- (lambda (f)
- (procedure->syntax
- (lambda (exp env)
- (copy-tree (apply f (cdr exp)))))))
-
-(define (macroexpand-1 e)
- (cond
- ((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (defined? a) (eval a))))
- (if (defmacro? val)
- (apply (defmacro-transformer val) (cdr e))
- e)))
- (#t e)))
-
-(define (macroexpand e)
- (cond
- ((pair? e) (let* ((a (car e))
- (val (and (symbol? a) (defined? a) (eval a))))
- (if (defmacro? val)
- (macroexpand (apply (defmacro-transformer val) (cdr e)))
- e)))
- (#t e)))
-
-(define gentemp
- (let ((*gensym-counter* -1))
- (lambda ()
- (set! *gensym-counter* (+ *gensym-counter* 1))
- (string->symbol
- (string-append "scm:G" (number->string *gensym-counter*))))))
-
-
-
-
-;;; {Running Repls}
-;;;
-
-(define (repl read evaler print)
- (let loop ((source (read (current-input-port) #t read-sharp)))
- (print (evaler source))
- (loop (read (current-input-port) #t read-sharp))))
-
-;; A provisional repl that acts like the SCM repl:
-;;
-(define scm-repl-silent #f)
-(define (assert-repl-silence v) (set! scm-repl-silent v))
-
-(define *unspecified* (if #f #f))
-(define (unspecified? v) (eq? v *unspecified*))
-
-(define scm-repl-print-unspecified #f)
-(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
-
-(define scm-repl-verbose #f)
-(define (assert-repl-verbosity v) (set! scm-repl-verbose v))
-
-(define scm-repl-prompt #t)
-(define (assert-repl-prompt v) (set! scm-repl-prompt v))
-
-(define the-prompt-string "guile> ")
-
-(define (error-catching-loop thunk)
- (define (loop first)
- (let ((next
- (catch #t
- (lambda ()
- (lazy-catch #t
- (lambda ()
- (dynamic-wind
- (lambda () (unmask-signals))
- (lambda ()
- (first)
-
- ;; This line is needed because mark doesn't do closures quite right.
- ;; Unreferenced locals should be collected.
- ;;
- (set! first #f)
- (let loop ((v (thunk)))
- (loop (thunk)))
- #f)
- (lambda () (mask-signals))))
-
- (lambda args
- (save-stack 1)
- (apply throw args))))
-
- (lambda (key . args)
- (case key
- ((quit)
- (force-output)
- #f)
-
- ((switch-repl)
- (apply throw 'switch-repl args))
-
- ((abort)
- ;; This is one of the closures that require
- ;; (set! first #f) above
- ;;
- (lambda ()
- (force-output)
- (display "ABORT: " (current-error-port))
- (write args (current-error-port))
- (newline (current-error-port))
- (if (and (not has-shown-debugger-hint?)
- (not (memq 'backtrace (debug-options-interface)))
- (stack? the-last-stack))
- (begin
- (newline (current-error-port))
- (display "Type \"(backtrace)\" to get more information,
-or type \"$\" to enter the debugger.\n" (current-error-port))
- (set! has-shown-debugger-hint? #t)))
- (set! stack-saved? #f)))
-
- (else
- ;; This is the other cons-leak closure...
- (lambda ()
- (cond ((= (length args) 4)
- (apply handle-system-error key args))
- (else
- (apply bad-throw key args))))))))))
- (and next (loop next))))
- (loop (lambda () #t)))
-
-(define the-last-stack #f)
-(define stack-saved? #f)
-
-(define (save-stack . narrowing)
- (cond (stack-saved?)
- ((not (memq 'debug (debug-options-interface)))
- (set! the-last-stack #f)
- (set! stack-saved? #t))
- (else
- (set! the-last-stack
- (case (stack-id #t)
- ((repl-stack)
- (apply make-stack #t save-stack eval narrowing))
- ((load-stack)
- (apply make-stack #t save-stack gsubr-apply narrowing))
- ((tk-stack)
- (apply make-stack #t save-stack tk-stack-mark narrowing))
- ((#t)
- (apply make-stack #t save-stack narrowing))
- (else (let ((id (stack-id #t)))
- (and (procedure? id)
- (apply make-stack #t save-stack id narrowing))))))
- (set! stack-saved? #t))))
-
-(define before-error-hook #f)
-(define after-error-hook #f)
-(define before-backtrace-hook #f)
-(define after-backtrace-hook #f)
-
-(define has-shown-debugger-hint? #f)
-
-(define (handle-system-error key . args)
- (let ((cep (current-error-port)))
- (cond ((not (stack? the-last-stack)))
- ((memq 'backtrace (debug-options-interface))
- (and before-backtrace-hook (before-backtrace-hook))
- (newline cep)
- (display-backtrace the-last-stack cep)
- (newline cep)
- (and after-backtrace-hook (after-backtrace-hook))))
- (and before-error-hook (before-error-hook))
- (apply display-error the-last-stack cep args)
- (and after-error-hook (after-error-hook))
- (force-output cep)
- (throw 'abort key)))
-
-(define (quit . args)
- (apply throw 'quit args))
-
-(define has-shown-backtrace-hint? #f)
-
-(define (backtrace)
- (if the-last-stack
- (begin
- (newline)
- (display-backtrace the-last-stack (current-output-port))
- (newline)
- (if (and (not has-shown-backtrace-hint?)
- (not (memq 'backtrace (debug-options-interface))))
- (begin
- (display
-"Type \"(debug-enable 'backtrace)\" if you would like a backtrace
-automatically if an error occurs in the future.\n")
- (set! has-shown-backtrace-hint? #t))))
- (display "No backtrace available.\n")))
-
-(define (error-catching-repl r e p)
- (error-catching-loop (lambda () (p (e (r))))))
-
-(define (gc-run-time)
- (cdr (assq 'gc-time-taken (gc-stats))))
-
-(define before-read-hook #f)
-(define after-read-hook #f)
-
-(define (scm-style-repl)
- (letrec (
- (start-gc-rt #f)
- (start-rt #f)
- (repl-report-reset (lambda () #f))
- (repl-report-start-timing (lambda ()
- (set! start-gc-rt (gc-run-time))
- (set! start-rt (get-internal-run-time))))
- (repl-report (lambda ()
- (display ";;; ")
- (display (inexact->exact
- (* 1000 (/ (- (get-internal-run-time) start-rt)
- internal-time-units-per-second))))
- (display " msec (")
- (display (inexact->exact
- (* 1000 (/ (- (gc-run-time) start-gc-rt)
- internal-time-units-per-second))))
- (display " msec in gc)\n")))
- (-read (lambda ()
- (if scm-repl-prompt
- (begin
- (display the-prompt-string)
- (force-output)
- (repl-report-reset)))
- (and before-read-hook (before-read-hook))
- (let ((val (read (current-input-port) #t read-sharp)))
- (and after-read-hook (after-read-hook))
- (if (eof-object? val)
- (begin
- (if scm-repl-verbose
- (begin
- (newline)
- (display ";;; EOF -- quitting")
- (newline)))
- (quit 0)))
- val)))
-
- (-eval (lambda (sourc)
- (repl-report-start-timing)
- (start-stack 'repl-stack (eval sourc))))
-
- (-print (lambda (result)
- (if (not scm-repl-silent)
- (begin
- (if (or scm-repl-print-unspecified
- (not (unspecified? result)))
- (begin
- (write result)
- (newline)))
- (if scm-repl-verbose
- (repl-report))
- (force-output)))))
-
- (-quit (lambda ()
- (if scm-repl-verbose
- (begin
- (display ";;; QUIT executed, repl exitting")
- (newline)
- (repl-report)))
- #t))
-
- (-abort (lambda ()
- (if scm-repl-verbose
- (begin
- (display ";;; ABORT executed.")
- (newline)
- (repl-report)))
- (repl -read -eval -print))))
-
- (error-catching-repl -read
- -eval
- -print)))
-
-(define (stand-alone-repl)
- (let ((oport (current-input-port)))
- (set-current-input-port *stdin*)
- (scm-style-repl)
- (set-current-input-port oport)))
-
-
-
-;;; {IOTA functions: generating lists of numbers}
-
-(define (reverse-iota n) (if (> n 0) (cons (1- n) (reverse-iota (1- n))) '()))
-(define (iota n) (list-reverse! (reverse-iota n)))
-
-
-;;; {While}
-;;;
-;;; with `continue' and `break'.
-;;;
-
-(defmacro while (cond . body)
- `(letrec ((continue (lambda () (or (not ,cond) (begin (begin ,@ body) (continue)))))
- (break (lambda val (apply throw 'break val))))
- (catch 'break
- (lambda () (continue))
- (lambda v (cadr v)))))
-
-
-
-
-;;; {Macros}
-;;;
-
-;; actually....hobbit might be able to hack these with a little
-;; coaxing
-;;
-
-(defmacro define-macro (first . rest)
- (let ((name (if (symbol? first) first (car first)))
- (transformer
- (if (symbol? first)
- (car rest)
- `(lambda ,(cdr first) ,@rest))))
- `(define ,name (defmacro:transformer ,transformer))))
-
-
-(defmacro define-syntax-macro (first . rest)
- (let ((name (if (symbol? first) first (car first)))
- (transformer
- (if (symbol? first)
- (car rest)
- `(lambda ,(cdr first) ,@rest))))
- `(define ,name (defmacro:syntax-transformer ,transformer))))
-
-;;; {Module System Macros}
-;;;
-
-(defmacro define-module args
- `(let* ((process-define-module process-define-module)
- (set-current-module set-current-module)
- (module (process-define-module ',args)))
- (set-current-module module)
- module))
-
-(define define-private define)
-
-(defmacro define-public args
- (define (syntax)
- (error "bad syntax" (list 'define-public args)))
- (define (defined-name n)
- (cond
- ((symbol? n) n)
- ((pair? n) (defined-name (car n)))
- (else (syntax))))
- (cond
- ((null? args) (syntax))
-
- (#t (let ((name (defined-name (car args))))
- `(begin
- (let ((public-i (module-public-interface (current-module))))
- ;; Make sure there is a local variable:
- ;;
- (module-define! (current-module)
- ',name
- (module-ref (current-module) ',name #f))
-
- ;; Make sure that local is exported:
- ;;
- (module-add! public-i ',name (module-variable (current-module) ',name)))
-
- ;; Now (re)define the var normally.
- ;;
- (define-private ,@ args))))))
-
-
-
-(defmacro defmacro-public args
- (define (syntax)
- (error "bad syntax" (list 'defmacro-public args)))
- (define (defined-name n)
- (cond
- ((symbol? n) n)
- (else (syntax))))
- (cond
- ((null? args) (syntax))
-
- (#t (let ((name (defined-name (car args))))
- `(begin
- (let ((public-i (module-public-interface (current-module))))
- ;; Make sure there is a local variable:
- ;;
- (module-define! (current-module)
- ',name
- (module-ref (current-module) ',name #f))
-
- ;; Make sure that local is exported:
- ;;
- (module-add! public-i ',name (module-variable (current-module) ',name)))
-
- ;; Now (re)define the var normally.
- ;;
- (defmacro ,@ args))))))
-
-
-
-
-(define load load-module)
-;(define (load . args)
-; (start-stack 'load-stack (apply load-module args)))
-
-
-
-;;; {I/O functions for Tcl channels (disabled)}
-
-;; (define in-ch (get-standard-channel TCL_STDIN))
-;; (define out-ch (get-standard-channel TCL_STDOUT))
-;; (define err-ch (get-standard-channel TCL_STDERR))
-;;
-;; (define inp (%make-channel-port in-ch "r"))
-;; (define outp (%make-channel-port out-ch "w"))
-;; (define errp (%make-channel-port err-ch "w"))
-;;
-;; (define %system-char-ready? char-ready?)
-;;
-;; (define (char-ready? p)
-;; (if (not (channel-port? p))
-;; (%system-char-ready? p)
-;; (let* ((channel (%channel-port-channel p))
-;; (old-blocking (channel-option-ref channel :blocking)))
-;; (dynamic-wind
-;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking "0"))
-;; (lambda () (not (eof-object? (peek-char p))))
-;; (lambda () (set-channel-option the-root-tcl-interpreter channel :blocking old-blocking))))))
-;;
-;; (define (top-repl)
-;; (with-input-from-port inp
-;; (lambda ()
-;; (with-output-to-port outp
-;; (lambda ()
-;; (with-error-to-port errp
-;; (lambda ()
-;; (scm-style-repl))))))))
-;;
-;; (set-current-input-port inp)
-;; (set-current-output-port outp)
-;; (set-current-error-port errp)
-
-(define (top-repl) (scm-style-repl))
-
-(defmacro false-if-exception (expr)
- `(catch #t (lambda () ,expr)
- (lambda args #f)))
-
-
-;;; {Calling Conventions}
-(define-module (ice-9 calling))
-
-;;;;
-;;;
-;;; This file contains a number of macros that support
-;;; common calling conventions.
-
-;;;
-;;; with-excursion-function <vars> proc
-;;; <vars> is an unevaluated list of names that are bound in the caller.
-;;; proc is a procedure, called:
-;;; (proc excursion)
-;;;
-;;; excursion is a procedure isolates all changes to <vars>
-;;; in the dynamic scope of the call to proc. In other words,
-;;; the values of <vars> are saved when proc is entered, and when
-;;; proc returns, those values are restored. Values are also restored
-;;; entering and leaving the call to proc non-locally, such as using
-;;; call-with-current-continuation, error, or throw.
-;;;
-(defmacro-public with-excursion-function (vars proc)
- `(,proc ,(excursion-function-syntax vars)))
-
-
-
-;;; with-getter-and-setter <vars> proc
-;;; <vars> is an unevaluated list of names that are bound in the caller.
-;;; proc is a procedure, called:
-;;; (proc getter setter)
-;;;
-;;; getter and setter are procedures used to access
-;;; or modify <vars>.
-;;;
-;;; setter, called with keywords arguments, modifies the named
-;;; values. If "foo" and "bar" are among <vars>, then:
-;;;
-;;; (setter :foo 1 :bar 2)
-;;; == (set! foo 1 bar 2)
-;;;
-;;; getter, called with just keywords, returns
-;;; a list of the corresponding values. For example,
-;;; if "foo" and "bar" are among the <vars>, then
-;;;
-;;; (getter :foo :bar)
-;;; => (<value-of-foo> <value-of-bar>)
-;;;
-;;; getter, called with no arguments, returns a list of all accepted
-;;; keywords and the corresponding values. If "foo" and "bar" are
-;;; the *only* <vars>, then:
-;;;
-;;; (getter)
-;;; => (:foo <value-of-bar> :bar <value-of-foo>)
-;;;
-;;; The unusual calling sequence of a getter supports too handy
-;;; idioms:
-;;;
-;;; (apply setter (getter)) ;; save and restore
-;;;
-;;; (apply-to-args (getter :foo :bar) ;; fetch and bind
-;;; (lambda (foo bar) ....))
-;;;
-;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it
-;;; ;; takes its arguments in a different order.
-;;;
-;;;
-(defmacro-public with-getter-and-setter (vars proc)
- `(,proc ,@ (getter-and-setter-syntax vars)))
-
-;;; with-getter vars proc
-;;; A short-hand for a call to with-getter-and-setter.
-;;; The procedure is called:
-;;; (proc getter)
-;;;
-(defmacro-public with-getter (vars proc)
- `(,proc ,(car (getter-and-setter-syntax vars))))
-
-
-;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
-;;; Compose getters and setters.
-;;;
-;;; <vars> is an unevaluated list of names that are bound in the caller.
-;;;
-;;; get-delegate is called by the new getter to extend the set of
-;;; gettable variables beyond just <vars>
-;;; set-delegate is called by the new setter to extend the set of
-;;; gettable variables beyond just <vars>
-;;;
-;;; proc is a procedure that is called
-;;; (proc getter setter)
-;;;
-(defmacro-public with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
- `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
-
-
-;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
-;;; <vars> is an unevaluated list of names that are bound in the caller.
-;;; proc is called:
-;;;
-;;; (proc excursion getter setter)
-;;;
-;;; See also:
-;;; with-getter-and-setter
-;;; with-excursion-function
-;;;
-(defmacro-public with-excursion-getter-and-setter (vars proc)
- `(,proc ,(excursion-function-syntax vars)
- ,@ (getter-and-setter-syntax vars)))
-
-
-(define (excursion-function-syntax vars)
- (let ((saved-value-names (map gensym vars))
- (tmp-var-name (gensym 'temp))
- (swap-fn-name (gensym 'swap))
- (thunk-name (gensym 'thunk)))
- `(lambda (,thunk-name)
- (letrec ((,tmp-var-name #f)
- (,swap-fn-name
- (lambda () ,@ (map (lambda (n sn) `(set! ,tmp-var-name ,n ,n ,sn ,sn ,tmp-var-name))
- vars saved-value-names)))
- ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
- (dynamic-wind
- ,swap-fn-name
- ,thunk-name
- ,swap-fn-name)))))
-
-
-(define (getter-and-setter-syntax vars)
- (let ((args-name (gensym 'args))
- (an-arg-name (gensym 'an-arg))
- (new-val-name (gensym 'new-value))
- (loop-name (gensym 'loop))
- (kws (map symbol->keyword vars)))
- (list `(lambda ,args-name
- (let ,loop-name ((,args-name ,args-name))
- (if (null? ,args-name)
- ,(if (null? kws)
- ''()
- `(let ((all-vals (,loop-name ',kws)))
- (let ,loop-name ((vals all-vals)
- (kws ',kws))
- (if (null? vals)
- '()
- `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
- (map (lambda (,an-arg-name)
- (case ,an-arg-name
- ,@ (append
- (map (lambda (kw v) `((,kw) ,v)) kws vars)
- `((else (throw 'bad-get-option ,an-arg-name))))))
- ,args-name))))
-
- `(lambda ,args-name
- (let ,loop-name ((,args-name ,args-name))
- (or (null? ,args-name)
- (null? (cdr ,args-name))
- (let ((,an-arg-name (car ,args-name))
- (,new-val-name (cadr ,args-name)))
- (case ,an-arg-name
- ,@ (append
- (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
- `((else (throw 'bad-set-option ,an-arg-name)))))
- (,loop-name (cddr ,args-name)))))))))
-
-(define (delegating-getter-and-setter-syntax vars get-delegate set-delegate)
- (let ((args-name (gensym 'args))
- (an-arg-name (gensym 'an-arg))
- (new-val-name (gensym 'new-value))
- (loop-name (gensym 'loop))
- (kws (map symbol->keyword vars)))
- (list `(lambda ,args-name
- (let ,loop-name ((,args-name ,args-name))
- (if (null? ,args-name)
- (append!
- ,(if (null? kws)
- ''()
- `(let ((all-vals (,loop-name ',kws)))
- (let ,loop-name ((vals all-vals)
- (kws ',kws))
- (if (null? vals)
- '()
- `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
- (,get-delegate))
- (map (lambda (,an-arg-name)
- (case ,an-arg-name
- ,@ (append
- (map (lambda (kw v) `((,kw) ,v)) kws vars)
- `((else (car (,get-delegate ,an-arg-name)))))))
- ,args-name))))
-
- `(lambda ,args-name
- (let ,loop-name ((,args-name ,args-name))
- (or (null? ,args-name)
- (null? (cdr ,args-name))
- (let ((,an-arg-name (car ,args-name))
- (,new-val-name (cadr ,args-name)))
- (case ,an-arg-name
- ,@ (append
- (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
- `((else (,set-delegate ,an-arg-name ,new-val-name)))))
- (,loop-name (cddr ,args-name)))))))))
-
-
-
-
-;;; with-configuration-getter-and-setter <vars-etc> proc
-;;;
-;;; Create a getter and setter that can trigger arbitrary computation.
-;;;
-;;; <vars-etc> is a list of variable specifiers, explained below.
-;;; proc is called:
-;;;
-;;; (proc getter setter)
-;;;
-;;; Each element of the <vars-etc> list is of the form:
-;;;
-;;; (<var> getter-hook setter-hook)
-;;;
-;;; Both hook elements are evaluated; the variable name is not.
-;;; Either hook may be #f or procedure.
-;;;
-;;; A getter hook is a thunk that returns a value for the corresponding
-;;; variable. If omitted (#f is passed), the binding of <var> is
-;;; returned.
-;;;
-;;; A setter hook is a procedure of one argument that accepts a new value
-;;; for the corresponding variable. If omitted, the binding of <var>
-;;; is simply set using set!.
-;;;
-(defmacro-public with-configuration-getter-and-setter (vars-etc proc)
- `((lambda (simpler-get simpler-set body-proc)
- (with-delegating-getter-and-setter ()
- simpler-get simpler-set body-proc))
-
- (lambda (kw)
- (case kw
- ,@(map (lambda (v) `((,(symbol->keyword (car v)))
- ,(cond
- ((cadr v) => list)
- (else `(list ,(car v))))))
- vars-etc)))
-
- (lambda (kw new-val)
- (case kw
- ,@(map (lambda (v) `((,(symbol->keyword (car v)))
- ,(cond
- ((caddr v) => (lambda (proc) `(,proc new-val)))
- (else `(set! ,(car v) new-val)))))
- vars-etc)))
-
- ,proc))
-
-(defmacro-public with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
- `((lambda (simpler-get simpler-set body-proc)
- (with-delegating-getter-and-setter ()
- simpler-get simpler-set body-proc))
-
- (lambda (kw)
- (case kw
- ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
- ,(cond
- ((cadr v) => list)
- (else `(list ,(car v))))))
- vars-etc)
- `((else (,delegate-get kw))))))
-
- (lambda (kw new-val)
- (case kw
- ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
- ,(cond
- ((caddr v) => (lambda (proc) `(,proc new-val)))
- (else `(set! ,(car v) new-val)))))
- vars-etc)
- `((else (,delegate-set kw new-val))))))
-
- ,proc))
-
-
-;;; let-configuration-getter-and-setter <vars-etc> proc
-;;;
-;;; This procedure is like with-configuration-getter-and-setter (q.v.)
-;;; except that each element of <vars-etc> is:
-;;;
-;;; (<var> initial-value getter-hook setter-hook)
-;;;
-;;; Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
-;;; introduces bindings for the variables named in <vars-etc>.
-;;; It is short-hand for:
-;;;
-;;; (let ((<var1> initial-value-1)
-;;; (<var2> initial-value-2)
-;;; ...)
-;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
-;;;
-(defmacro-public let-with-configuration-getter-and-setter (vars-etc proc)
- `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
- (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
- ,proc)))
-
-
-
-
-;;; {Implementation of COMMON LISP list functions for Scheme}
-
-(define-module (ice-9 common-list))
-
-;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
-; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
-;
-;Permission to copy this software, to redistribute it, and to use it
-;for any purpose is granted, subject to the following restrictions and
-;understandings.
-;
-;1. Any copy made of this software must include this copyright notice
-;in full.
-;
-;2. I have made no warrantee or representation that the operation of
-;this software will be error-free, and I am under no obligation to
-;provide any services, by way of maintenance, update, or otherwise.
-;
-;3. In conjunction with products arising from the use of this
-;material, there shall be no use of my name in any advertising,
-;promotional, or sales literature without prior written consent in
-;each case.
-
-;;;From: hugh@ear.mit.edu (Hugh Secker-Walker)
-(define-public (make-list k . init)
- (set! init (if (pair? init) (car init)))
- (do ((k k (+ -1 k))
- (result '() (cons init result)))
- ((<= k 0) result)))
-
-(define-public (adjoin e l) (if (memq e l) l (cons e l)))
-
-(define-public (union l1 l2)
- (cond ((null? l1) l2)
- ((null? l2) l1)
- (else (union (cdr l1) (adjoin (car l1) l2)))))
-
-(define-public (intersection l1 l2)
- (cond ((null? l1) l1)
- ((null? l2) l2)
- ((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2)))
- (else (intersection (cdr l1) l2))))
-
-(define-public (set-difference l1 l2)
- (cond ((null? l1) l1)
- ((memv (car l1) l2) (set-difference (cdr l1) l2))
- (else (cons (car l1) (set-difference (cdr l1) l2)))))
-
-(define-public (reduce-init p init l)
- (if (null? l)
- init
- (reduce-init p (p init (car l)) (cdr l))))
-
-(define-public (reduce p l)
- (cond ((null? l) l)
- ((null? (cdr l)) (car l))
- (else (reduce-init p (car l) (cdr l)))))
-
-(define-public (some pred l . rest)
- (cond ((null? rest)
- (let mapf ((l l))
- (and (not (null? l))
- (or (pred (car l)) (mapf (cdr l))))))
- (else (let mapf ((l l) (rest rest))
- (and (not (null? l))
- (or (apply pred (car l) (map car rest))
- (mapf (cdr l) (map cdr rest))))))))
-
-(define-public (every pred l . rest)
- (cond ((null? rest)
- (let mapf ((l l))
- (or (null? l)
- (and (pred (car l)) (mapf (cdr l))))))
- (else (let mapf ((l l) (rest rest))
- (or (null? l)
- (and (apply pred (car l) (map car rest))
- (mapf (cdr l) (map cdr rest))))))))
-
-(define-public (notany pred . ls) (not (apply some pred ls)))
-
-(define-public (notevery pred . ls) (not (apply every pred ls)))
-
-(define-public (find-if t l)
- (cond ((null? l) #f)
- ((t (car l)) (car l))
- (else (find-if t (cdr l)))))
-
-(define-public (member-if t l)
- (cond ((null? l) #f)
- ((t (car l)) l)
- (else (member-if t (cdr l)))))
-
-(define-public (remove-if p l)
- (cond ((null? l) '())
- ((p (car l)) (remove-if p (cdr l)))
- (else (cons (car l) (remove-if p (cdr l))))))
-
-(define-public (delete-if! pred list)
- (let delete-if ((list list))
- (cond ((null? list) '())
- ((pred (car list)) (delete-if (cdr list)))
- (else
- (set-cdr! list (delete-if (cdr list)))
- list))))
-
-(define-public (delete-if-not! pred list)
- (let delete-if ((list list))
- (cond ((null? list) '())
- ((not (pred (car list))) (delete-if (cdr list)))
- (else
- (set-cdr! list (delete-if (cdr list)))
- list))))
-
-(define-public (butlast lst n)
- (letrec ((l (- (length lst) n))
- (bl (lambda (lst n)
- (cond ((null? lst) lst)
- ((positive? n)
- (cons (car lst) (bl (cdr lst) (+ -1 n))))
- (else '())))))
- (bl lst (if (negative? n)
- (slib:error "negative argument to butlast" n)
- l))))
-
-(define-public (and? . args)
- (cond ((null? args) #t)
- ((car args) (apply and? (cdr args)))
- (else #f)))
-
-(define-public (or? . args)
- (cond ((null? args) #f)
- ((car args) #t)
- (else (apply or? (cdr args)))))
-
-(define-public (has-duplicates? lst)
- (cond ((null? lst) #f)
- ((member (car lst) (cdr lst)) #t)
- (else (has-duplicates? (cdr lst)))))
-
-(define-public (list* x . y)
- (define (list*1 x)
- (if (null? (cdr x))
- (car x)
- (cons (car x) (list*1 (cdr x)))))
- (if (null? y)
- x
- (cons x (list*1 y))))
-
-;; pick p l
-;; Apply P to each element of L, returning a list of elts
-;; for which P returns a non-#f value.
-;;
-(define-public (pick p l)
- (let loop ((s '())
- (l l))
- (cond
- ((null? l) s)
- ((p (car l)) (loop (cons (car l) s) (cdr l)))
- (else (loop s (cdr l))))))
-
-;; pick p l
-;; Apply P to each element of L, returning a list of the
-;; non-#f return values of P.
-;;
-(define-public (pick-mappings p l)
- (let loop ((s '())
- (l l))
- (cond
- ((null? l) s)
- ((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l))))
- (else (loop s (cdr l))))))
-
-(define-public (uniq l)
- (if (null? l)
- '()
- (let ((u (uniq (cdr l))))
- (if (memq (car l) u)
- u
- (cons (car l) u)))))
-
-
-;;; {Functions for browsing modules}
-
-(define-module (ice-9 ls)
- :use-module (ice-9 common-list))
-
-;;;;
-;;; local-definitions-in root name
-;;; Returns a list of names defined locally in the named
-;;; subdirectory of root.
-;;; definitions-in root name
-;;; Returns a list of all names defined in the named
-;;; subdirectory of root. The list includes alll locally
-;;; defined names as well as all names inherited from a
-;;; member of a use-list.
-;;;
-;;; A convenient interface for examining the nature of things:
-;;;
-;;; ls . various-names
-;;;
-;;; With just one argument, interpret that argument as the
-;;; name of a subdirectory of the current module and
-;;; return a list of names defined there.
-;;;
-;;; With more than one argument, still compute
-;;; subdirectory lists, but return a list:
-;;; ((<subdir-name> . <names-defined-there>)
-;;; (<subdir-name> . <names-defined-there>)
-;;; ...)
-;;;
-
-(define-public (local-definitions-in root names)
- (let ((m (nested-ref root names))
- (answer '()))
- (if (not (module? m))
- (set! answer m)
- (module-for-each (lambda (k v) (set! answer (cons k answer))) m))
- answer))
-
-(define-public (definitions-in root names)
- (let ((m (nested-ref root names)))
- (if (not (module? m))
- m
- (reduce union
- (cons (local-definitions-in m '())
- (map (lambda (m2) (definitions-in m2 '()))
- (module-uses m)))))))
-
-(define-public (ls . various-refs)
- (and various-refs
- (if (cdr various-refs)
- (map (lambda (ref)
- (cons ref (definitions-in (current-module) ref)))
- various-refs)
- (definitions-in (current-module) (car various-refs)))))
-
-(define-public (lls . various-refs)
- (and various-refs
- (if (cdr various-refs)
- (map (lambda (ref)
- (cons ref (local-definitions-in (current-module) ref)))
- various-refs)
- (local-definitions-in (current-module) (car various-refs)))))
-
-(define-public (recursive-local-define name value)
- (let ((parent (reverse! (cdr (reverse name)))))
- (and parent (make-modules-in (current-module) parent))
- (local-define name value)))
-
-;;; {Queues}
-
-(define-module (ice-9 q))
-
-;;;; Copyright (C) 1995 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-;;;;
-;;; Q: Based on the interface to
-;;;
-;;; "queue.scm" Queues/Stacks for Scheme
-;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
-;;;
-
-;;;;
-;;; {Q}
-;;;
-;;; A list is just a bunch of cons pairs that follows some constrains, right?
-;;; Association lists are the same. Hash tables are just vectors and association
-;;; lists. You can print them, read them, write them as constants, pun them off as other data
-;;; structures etc. This is good. This is lisp. These structures are fast and compact
-;;; and easy to manipulate arbitrarily because of their simple, regular structure and
-;;; non-disjointedness (associations being lists and so forth).
-;;;
-;;; So I figured, queues should be the same -- just a "subtype" of cons-pair
-;;; structures in general.
-;;;
-;;; A queue is a cons pair:
-;;; ( <the-q> . <last-pair> )
-;;;
-;;; <the-q> is a list of things in the q. New elements go at the end of that list.
-;;;
-;;; <last-pair> is #f if the q is empty, and otherwise is the last pair of <the-q>.
-;;;
-;;; q's print nicely, but alas, they do not read well because the eq?-ness of
-;;; <last-pair> and (last-pair <the-q>) is lost by read. The procedure
-;;;
-;;; (sync-q! q)
-;;;
-;;; recomputes and resets the <last-pair> component of a queue.
-;;;
-
-(define-public (sync-q! obj) (set-cdr! obj (and (car obj) (last-pair (car obj)))))
-
-;;; make-q
-;;; return a new q.
-;;;
-(define-public (make-q) (cons '() '()))
-
-;;; q? obj
-;;; Return true if obj is a Q.
-;;; An object is a queue if it is equal? to '(#f . #f) or
-;;; if it is a pair P with (list? (car P)) and (eq? (cdr P) (last-pair P)).
-;;;
-(define-public (q? obj) (and (pair? obj)
- (or (and (null? (car obj))
- (null? (cdr obj)))
- (and
- (list? (car obj))
- (eq? (cdr obj) (last-pair (car obj)))))))
-
-;;; q-empty? obj
-;;;
-(define-public (q-empty? obj) (null? (car obj)))
-
-;;; q-empty-check q
-;;; Throw a q-empty exception if Q is empty.
-(define-public (q-empty-check q) (if (q-empty? q) (throw 'q-empty q)))
-
-
-;;; q-front q
-;;; Return the first element of Q.
-(define-public (q-front q) (q-empty-check q) (caar q))
-
-;;; q-front q
-;;; Return the last element of Q.
-(define-public (q-rear q) (q-empty-check q) (cadr q))
-
-;;; q-remove! q obj
-;;; Remove all occurences of obj from Q.
-(define-public (q-remove! q obj)
- (while (memq obj (car q))
- (set-car! q (delq! obj (car q))))
- (set-cdr! q (last-pair (car q))))
-
-;;; q-push! q obj
-;;; Add obj to the front of Q
-(define-public (q-push! q d)
- (let ((h (cons d (car q))))
- (set-car! q h)
- (if (null? (cdr q))
- (set-cdr! q h))))
-
-;;; enq! q obj
-;;; Add obj to the rear of Q
-(define-public (enq! q d)
- (let ((h (cons d '())))
- (if (not (null? (cdr q)))
- (set-cdr! (cdr q) h)
- (set-car! q h))
- (set-cdr! q h)))
-
-;;; q-pop! q
-;;; Take the front of Q and return it.
-(define-public (q-pop! q)
- (q-empty-check q)
- (let ((it (caar q))
- (next (cdar q)))
- (if (not next)
- (set-cdr! q #f))
- (set-car! q next)
- it))
-
-;;; deq! q
-;;; Take the front of Q and return it.
-(define-public deq! q-pop!)
-
-;;; q-length q
-;;; Return the number of enqueued elements.
-;;;
-(define-public (q-length q) (length (car q)))
-
-
-
-
-;;; {The runq data structure}
-
-(define-module (ice-9 runq)
- :use-module (ice-9 q))
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-;;;;
-;;;
-;;; One way to schedule parallel computations in a serial environment is
-;;; to explicitly divide each task up into small, finite execution time,
-;;; strips. Then you interleave the execution of strips from various
-;;; tasks to achieve a kind of parallelism. Runqs are a handy data
-;;; structure for this style of programming.
-;;;
-;;; We use thunks (nullary procedures) and lists of thunks to represent
-;;; strips. By convention, the return value of a strip-thunk must either
-;;; be another strip or the value #f.
-;;;
-;;; A runq is a procedure that manages a queue of strips. Called with no
-;;; arguments, it processes one strip from the queue. Called with
-;;; arguments, the arguments form a control message for the queue. The
-;;; first argument is a symbol which is the message selector.
-;;;
-;;; A strip is processed this way: If the strip is a thunk, the thunk is
-;;; called -- if it returns a strip, that strip is added back to the
-;;; queue. To process a strip which is a list of thunks, the CAR of that
-;;; list is called. After a call to that CAR, there are 0, 1, or 2 strips
-;;; -- perhaps one returned by the thunk, and perhaps the CDR of the
-;;; original strip if that CDR is not nil. The runq puts whichever of
-;;; these strips exist back on the queue. (The exact order in which
-;;; strips are put back on the queue determines the scheduling behavior of
-;;; a particular queue -- it's a parameter.)
-;;;
-;;;
-
-
-
-;;;;
-;;; (runq-control q msg . args)
-;;;
-;;; processes in the default way the control messages that
-;;; can be sent to a runq. Q should be an ordinary
-;;; Q (see utils/q.scm).
-;;;
-;;; The standard runq messages are:
-;;;
-;;; 'add! strip0 strip1... ;; to enqueue one or more strips
-;;; 'enqueue! strip0 strip1... ;; to enqueue one or more strips
-;;; 'push! strip0 ... ;; add strips to the front of the queue
-;;; 'empty? ;; true if it is
-;;; 'length ;; how many strips in the queue?
-;;; 'kill! ;; empty the queue
-;;; else ;; throw 'not-understood
-;;;
-(define-public (runq-control q msg . args)
- (case msg
- ((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
- ((enque!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
- ((push!) (for-each (lambda (t) (q-push! q t)) args) '*unspecified*)
- ((empty?) (q-empty? q))
- ((length) (q-length q))
- ((kill!) (set! q (make-q)))
- (else (throw 'not-understood msg args))))
-
-(define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f)))
-
-;;;;
-;;; make-void-runq
-;;;
-;;; Make a runq that discards all messages except "length", for which
-;;; it returns 0.
-;;;
-(define-public (make-void-runq)
- (lambda opts
- (and opts
- (apply-to-args opts
- (lambda (msg . args)
- (case msg
- ((length) 0)
- (else #f)))))))
-
-;;;;
-;;; (make-fair-runq)
-;;;
-;;; Returns a runq procedure.
-;;; Called with no arguments, the procedure processes one strip from the queue.
-;;; Called with arguments, it uses runq-control.
-;;;
-;;; In a fair runq, if a strip returns a new strip X, X is added
-;;; to the end of the queue, meaning it will be the last to execute
-;;; of all the remaining procedures.
-;;;
-(define-public (make-fair-runq)
- (letrec ((q (make-q))
- (self
- (lambda ctl
- (if ctl
- (apply runq-control q ctl)
- (and (not (q-empty? q))
- (let ((next-strip (deq! q)))
- (cond
- ((procedure? next-strip) (let ((k (run-strip next-strip)))
- (and k (enq! q k))))
- ((pair? next-strip) (let ((k (run-strip (car next-strip))))
- (and k (enq! q k)))
- (if (not (null? (cdr next-strip)))
- (enq! q (cdr next-strip)))))
- self))))))
- self))
-
-
-;;;;
-;;; (make-exclusive-runq)
-;;;
-;;; Returns a runq procedure.
-;;; Called with no arguments, the procedure processes one strip from the queue.
-;;; Called with arguments, it uses runq-control.
-;;;
-;;; In an exclusive runq, if a strip W returns a new strip X, X is added
-;;; to the front of the queue, meaning it will be the next to execute
-;;; of all the remaining procedures.
-;;;
-;;; An exception to this occurs if W was the CAR of a list of strips.
-;;; In that case, after the return value of W is pushed onto the front
-;;; of the queue, the CDR of the list of strips is pushed in front
-;;; of that (if the CDR is not nil). This way, the rest of the thunks
-;;; in the list that contained W have priority over the return value of W.
-;;;
-(define-public (make-exclusive-runq)
- (letrec ((q (make-q))
- (self
- (lambda ctl
- (if ctl
- (apply runq-control q ctl)
- (and (not (q-empty? q))
- (let ((next-strip (deq! q)))
- (cond
- ((procedure? next-strip) (let ((k (run-strip next-strip)))
- (and k (q-push! q k))))
- ((pair? next-strip) (let ((k (run-strip (car next-strip))))
- (and k (q-push! q k)))
- (if (not (null? (cdr next-strip)))
- (q-push! q (cdr next-strip)))))
- self))))))
- self))
-
-
-;;;;
-;;; (make-subordinate-runq-to superior basic-inferior)
-;;;
-;;; Returns a runq proxy for the runq basic-inferior.
-;;;
-;;; The proxy watches for operations on the basic-inferior that cause
-;;; a transition from a queue length of 0 to a non-zero length and
-;;; vice versa. While the basic-inferior queue is not empty,
-;;; the proxy installs a task on the superior runq. Each strip
-;;; of that task processes N strips from the basic-inferior where
-;;; N is the length of the basic-inferior queue when the proxy
-;;; strip is entered. [Countless scheduling variations are possible.]
-;;;
-(define-public (make-subordinate-runq-to superior-runq basic-runq)
- (let ((runq-task (cons #f #f)))
- (set-car! runq-task
- (lambda ()
- (if (basic-runq 'empty?)
- (set-cdr! runq-task #f)
- (do ((n (basic-runq 'length) (1- n)))
- ((<= n 0) #f)
- (basic-runq)))))
- (letrec ((self
- (lambda ctl
- (if (not ctl)
- (let ((answer (basic-runq)))
- (self 'empty?)
- answer)
- (begin
- (case (car ctl)
- ((suspend) (set-cdr! runq-task #f))
- (else (let ((answer (apply basic-runq ctl)))
- (if (and (not (cdr runq-task)) (not (basic-runq 'empty?)))
- (begin
- (set-cdr! runq-task runq-task)
- (superior-runq 'add! runq-task)))
- answer))))))))
- self)))
-
-;;;;
-;;; (define fork-strips (lambda args args))
-;;; Return a strip that starts several strips in
-;;; parallel. If this strip is enqueued on a fair
-;;; runq, strips of the parallel subtasks will run
-;;; round-robin style.
-;;;
-(define fork-strips (lambda args args))
-
-
-;;;;
-;;; (strip-sequence . strips)
-;;;
-;;; Returns a new strip which is the concatenation of the argument strips.
-;;;
-(define-public ((strip-sequence . strips))
- (let loop ((st (let ((a strips)) (set! strips #f) a)))
- (and (not (null? st))
- (let ((then ((car st))))
- (if then
- (lambda () (loop (cons then (cdr st))))
- (lambda () (loop (cdr st))))))))
-
-
-;;;;
-;;; (fair-strip-subtask . initial-strips)
-;;;
-;;; Returns a new strip which is the synchronos, fair,
-;;; parallel execution of the argument strips.
-;;;
-;;;
-;;;
-(define-public (fair-strip-subtask . initial-strips)
- (let ((st (make-fair-runq)))
- (apply st 'add! initial-strips)
- st))
-
-
-;;; {String Fun}
-
-(define-module (ice-9 string-fun))
-
-;;;;
-;;;
-;;; Various string funcitons, particularly those that take
-;;; advantage of the "shared substring" capability.
-;;;
-
-;;; {String Fun: Dividing Strings Into Fields}
-;;;
-;;; The names of these functions are very regular.
-;;; Here is a grammar of a call to one of these:
-;;;
-;;; <string-function-invocation>
-;;; := (<action>-<seperator-disposition>-<seperator-determination> <seperator-param> <str> <ret>)
-;;;
-;;; <str> = the string
-;;;
-;;; <ret> = The continuation. String functions generally return
-;;; multiple values by passing them to this procedure.
-;;;
-;;; <action> = split
-;;; | separate-fields
-;;;
-;;; "split" means to divide a string into two parts.
-;;; <ret> will be called with two arguments.
-;;;
-;;; "separate-fields" means to divide a string into as many
-;;; parts as possible. <ret> will be called with
-;;; however many fields are found.
-;;;
-;;; <seperator-disposition> = before
-;;; | after
-;;; | discarding
-;;;
-;;; "before" means to leave the seperator attached to
-;;; the beginning of the field to its right.
-;;; "after" means to leave the seperator attached to
-;;; the end of the field to its left.
-;;; "discarding" means to discard seperators.
-;;;
-;;; Other dispositions might be handy. For example, "isolate"
-;;; could mean to treat the separator as a field unto itself.
-;;;
-;;; <seperator-determination> = char
-;;; | predicate
-;;;
-;;; "char" means to use a particular character as field seperator.
-;;; "predicate" means to check each character using a particular predicate.
-;;;
-;;; Other determinations might be handy. For example, "character-set-member".
-;;;
-;;; <seperator-param> = A parameter that completes the meaning of the determinations.
-;;; For example, if the determination is "char", then this parameter
-;;; says which character. If it is "predicate", the parameter is the
-;;; predicate.
-;;;
-;;;
-;;; For example:
-;;;
-;;; (separate-fields-discarding-char #\, "foo, bar, baz, , bat" list)
-;;; => ("foo" " bar" " baz" " " " bat")
-;;;
-;;; (split-after-char #\- 'an-example-of-split list)
-;;; => ("an-" "example-of-split")
-;;;
-;;; As an alternative to using a determination "predicate", or to trying to do anything
-;;; complicated with these functions, consider using regular expressions.
-;;;
-
-(define-public (split-after-char char str ret)
- (let ((end (cond
- ((string-index str char) => 1+)
- (else (string-length str)))))
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str end))))
-
-(define-public (split-before-char char str ret)
- (let ((end (or (string-index str char)
- (string-length str))))
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str end))))
-
-(define-public (split-discarding-char char str ret)
- (let ((end (string-index str char)))
- (if (not end)
- (ret str "")
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str (1+ end))))))
-
-(define-public (split-after-char-last char str ret)
- (let ((end (cond
- ((string-rindex str char) => 1+)
- (else 0))))
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str end))))
-
-(define-public (split-before-char-last char str ret)
- (let ((end (or (string-rindex str char) 0)))
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str end))))
-
-(define-public (split-discarding-char-last char str ret)
- (let ((end (string-rindex str char)))
- (if (not end)
- (ret str "")
- (ret (make-shared-substring str 0 end)
- (make-shared-substring str (1+ end))))))
-
-(define (split-before-predicate pred str ret)
- (let loop ((n 0))
- (cond
- ((= n (length str)) (ret str ""))
- ((not (pred (string-ref str n))) (loop (1+ n)))
- (else (ret (make-shared-substring str 0 n)
- (make-shared-substring str n))))))
-(define (split-after-predicate pred str ret)
- (let loop ((n 0))
- (cond
- ((= n (length str)) (ret str ""))
- ((not (pred (string-ref str n))) (loop (1+ n)))
- (else (ret (make-shared-substring str 0 (1+ n))
- (make-shared-substring str (1+ n)))))))
-
-(define (split-discarding-predicate pred str ret)
- (let loop ((n 0))
- (cond
- ((= n (length str)) (ret str ""))
- ((not (pred (string-ref str n))) (loop (1+ n)))
- (else (ret (make-shared-substring str 0 n)
- (make-shared-substring str (1+ n)))))))
-
-(define-public (separate-fields-discarding-char ch str ret)
- (let loop ((fields '())
- (str str))
- (cond
- ((string-rindex str ch)
- => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields)
- (make-shared-substring str 0 w))))
- (else (ret (cons str fields))))))
-
-(define-public (separate-fields-after-char ch str ret)
- (let loop ((fields '())
- (str str))
- (cond
- ((string-rindex str ch)
- => (lambda (pos) (loop (cons (make-shared-substring str (+ 1 w)) fields)
- (make-shared-substring str 0 (+ 1 w)))))
- (else (ret (cons str fields))))))
-
-(define-public (separate-fields-before-char ch str ret)
- (let loop ((fields '())
- (str str))
- (cond
- ((string-rindex str ch)
- => (lambda (pos) (loop (cons (make-shared-substring str w) fields)
- (make-shared-substring str 0 w))))
- (else (ret (cons str fields))))))
-
-
-;;; {String Fun: String Prefix Predicates}
-;;;
-;;; Very simple:
-;;;
-;;; (define-public ((string-prefix-predicate pred?) prefix str)
-;;; (and (<= (length prefix) (length str))
-;;; (pred? prefix (make-shared-substring str 0 (length prefix)))))
-;;;
-;;; (define-public string-prefix=? (string-prefix-predicate string=?))
-;;;
-
-(define-public ((string-prefix-predicate pred?) prefix str)
- (and (<= (length prefix) (length str))
- (pred? prefix (make-shared-substring str 0 (length prefix)))))
-
-(define-public string-prefix=? (string-prefix-predicate string=?))
-
-
-;;; {String Fun: Strippers}
-;;;
-;;; <stripper> = sans-<removable-part>
-;;;
-;;; <removable-part> = surrounding-whitespace
-;;; | trailing-whitespace
-;;; | leading-whitespace
-;;; | final-newline
-;;;
-
-(define-public (sans-surrounding-whitespace s)
- (let ((st 0)
- (end (string-length s)))
- (while (and (< st (string-length s))
- (char-whitespace? (string-ref s st)))
- (set! st (1+ st)))
- (while (and (< 0 end)
- (char-whitespace? (string-ref s (1- end))))
- (set! end (1- end)))
- (if (< end st)
- ""
- (make-shared-substring s st end))))
-
-(define-public (sans-trailing-whitespace s)
- (let ((st 0)
- (end (string-length s)))
- (while (and (< 0 end)
- (char-whitespace? (string-ref s (1- end))))
- (set! end (1- end)))
- (if (< end st)
- ""
- (make-shared-substring s st end))))
-
-(define-public (sans-leading-whitespace s)
- (let ((st 0)
- (end (string-length s)))
- (while (and (< st (string-length s))
- (char-whitespace? (string-ref s st)))
- (set! st (1+ st)))
- (if (< end st)
- ""
- (make-shared-substring s st end))))
-
-(define-public (sans-final-newline str)
- (cond
- ((= 0 (string-length str))
- str)
-
- ((char=? #\nl (string-ref str (1- (string-length str))))
- (make-shared-substring str 0 (1- (string-length str))))
-
- (else str)))
-
-;;; {String Fun: has-trailing-newline?}
-;;;
-
-(define-public (has-trailing-newline? str)
- (and (< 0 (string-length str))
- (char=? #\nl (string-ref str (1- (string-length str))))))
-
-
-
-;;; {String Fun: with-regexp-parts}
-
-(define-public (with-regexp-parts regexp fields str return fail)
- (let ((parts (regexec regexp str fields)))
- (if (number? parts)
- (fail parts)
- (apply return parts))))
-
-
-;;; {Load debug extension code if debug extensions present.}
-;;;
-;;; *fixme* This is a temporary solution.
-;;;
-
-(if (memq 'debug-extensions *features*)
- (define-module (guile) :use-module (ice-9 debug)))
-
-
-;;; {Load thread code if threads are present.}
-;;;
-;;; *fixme* This is a temporary solution.
-;;;
-
-(if (memq 'threads *features*)
- (define-module (guile) :use-module (ice-9 threads)))
-
-
-;;; {Load emacs interface support if emacs option is given.}
-;;;
-;;; *fixme* This is a temporary solution.
-;;;
-
-(if (or (member "-e" (cdr (program-arguments)))
- (member "--emacs" (cdr (program-arguments))))
- (define-module (guile) :use-module (ice-9 emacs)))
-
-
-
-(define-module (guile))
-
-(append! %load-path (cons "." ()))
diff --git a/ice-9/configure b/ice-9/configure
deleted file mode 100755
index 4676147d1..000000000
--- a/ice-9/configure
+++ /dev/null
@@ -1,961 +0,0 @@
-#! /bin/sh
-
-# Guess values for system-dependent variables and create Makefiles.
-# Generated automatically using autoconf version 2.12
-# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
-#
-# This configure script is free software; the Free Software Foundation
-# gives unlimited permission to copy, distribute and modify it.
-
-# Defaults:
-ac_help=
-ac_default_prefix=/usr/local
-# Any additions from configure.in:
-
-# Initialize some variables set by options.
-# The variables have the same names as the options, with
-# dashes changed to underlines.
-build=NONE
-cache_file=./config.cache
-exec_prefix=NONE
-host=NONE
-no_create=
-nonopt=NONE
-no_recursion=
-prefix=NONE
-program_prefix=NONE
-program_suffix=NONE
-program_transform_name=s,x,x,
-silent=
-site=
-srcdir=
-target=NONE
-verbose=
-x_includes=NONE
-x_libraries=NONE
-bindir='${exec_prefix}/bin'
-sbindir='${exec_prefix}/sbin'
-libexecdir='${exec_prefix}/libexec'
-datadir='${prefix}/share'
-sysconfdir='${prefix}/etc'
-sharedstatedir='${prefix}/com'
-localstatedir='${prefix}/var'
-libdir='${exec_prefix}/lib'
-includedir='${prefix}/include'
-oldincludedir='/usr/include'
-infodir='${prefix}/info'
-mandir='${prefix}/man'
-
-# Initialize some other variables.
-subdirs=
-MFLAGS= MAKEFLAGS=
-# Maximum number of lines to put in a shell here document.
-ac_max_here_lines=12
-
-ac_prev=
-for ac_option
-do
-
- # If the previous option needs an argument, assign it.
- if test -n "$ac_prev"; then
- eval "$ac_prev=\$ac_option"
- ac_prev=
- continue
- fi
-
- case "$ac_option" in
- -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
- *) ac_optarg= ;;
- esac
-
- # Accept the important Cygnus configure options, so we can diagnose typos.
-
- case "$ac_option" in
-
- -bindir | --bindir | --bindi | --bind | --bin | --bi)
- ac_prev=bindir ;;
- -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
- bindir="$ac_optarg" ;;
-
- -build | --build | --buil | --bui | --bu)
- ac_prev=build ;;
- -build=* | --build=* | --buil=* | --bui=* | --bu=*)
- build="$ac_optarg" ;;
-
- -cache-file | --cache-file | --cache-fil | --cache-fi \
- | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
- ac_prev=cache_file ;;
- -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
- | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
- cache_file="$ac_optarg" ;;
-
- -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
- ac_prev=datadir ;;
- -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
- | --da=*)
- datadir="$ac_optarg" ;;
-
- -disable-* | --disable-*)
- ac_feature=`echo $ac_option|sed -e 's/-*disable-//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then
- { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
- fi
- ac_feature=`echo $ac_feature| sed 's/-/_/g'`
- eval "enable_${ac_feature}=no" ;;
-
- -enable-* | --enable-*)
- ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then
- { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
- fi
- ac_feature=`echo $ac_feature| sed 's/-/_/g'`
- case "$ac_option" in
- *=*) ;;
- *) ac_optarg=yes ;;
- esac
- eval "enable_${ac_feature}='$ac_optarg'" ;;
-
- -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
- | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
- | --exec | --exe | --ex)
- ac_prev=exec_prefix ;;
- -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
- | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
- | --exec=* | --exe=* | --ex=*)
- exec_prefix="$ac_optarg" ;;
-
- -gas | --gas | --ga | --g)
- # Obsolete; use --with-gas.
- with_gas=yes ;;
-
- -help | --help | --hel | --he)
- # Omit some internal or obsolete options to make the list less imposing.
- # This message is too long to be a string in the A/UX 3.1 sh.
- cat << EOF
-Usage: configure [options] [host]
-Options: [defaults in brackets after descriptions]
-Configuration:
- --cache-file=FILE cache test results in FILE
- --help print this message
- --no-create do not create output files
- --quiet, --silent do not print \`checking...' messages
- --version print the version of autoconf that created configure
-Directory and file names:
- --prefix=PREFIX install architecture-independent files in PREFIX
- [$ac_default_prefix]
- --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
- [same as prefix]
- --bindir=DIR user executables in DIR [EPREFIX/bin]
- --sbindir=DIR system admin executables in DIR [EPREFIX/sbin]
- --libexecdir=DIR program executables in DIR [EPREFIX/libexec]
- --datadir=DIR read-only architecture-independent data in DIR
- [PREFIX/share]
- --sysconfdir=DIR read-only single-machine data in DIR [PREFIX/etc]
- --sharedstatedir=DIR modifiable architecture-independent data in DIR
- [PREFIX/com]
- --localstatedir=DIR modifiable single-machine data in DIR [PREFIX/var]
- --libdir=DIR object code libraries in DIR [EPREFIX/lib]
- --includedir=DIR C header files in DIR [PREFIX/include]
- --oldincludedir=DIR C header files for non-gcc in DIR [/usr/include]
- --infodir=DIR info documentation in DIR [PREFIX/info]
- --mandir=DIR man documentation in DIR [PREFIX/man]
- --srcdir=DIR find the sources in DIR [configure dir or ..]
- --program-prefix=PREFIX prepend PREFIX to installed program names
- --program-suffix=SUFFIX append SUFFIX to installed program names
- --program-transform-name=PROGRAM
- run sed PROGRAM on installed program names
-EOF
- cat << EOF
-Host type:
- --build=BUILD configure for building on BUILD [BUILD=HOST]
- --host=HOST configure for HOST [guessed]
- --target=TARGET configure for TARGET [TARGET=HOST]
-Features and packages:
- --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
- --enable-FEATURE[=ARG] include FEATURE [ARG=yes]
- --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
- --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
- --x-includes=DIR X include files are in DIR
- --x-libraries=DIR X library files are in DIR
-EOF
- if test -n "$ac_help"; then
- echo "--enable and --with options recognized:$ac_help"
- fi
- exit 0 ;;
-
- -host | --host | --hos | --ho)
- ac_prev=host ;;
- -host=* | --host=* | --hos=* | --ho=*)
- host="$ac_optarg" ;;
-
- -includedir | --includedir | --includedi | --included | --include \
- | --includ | --inclu | --incl | --inc)
- ac_prev=includedir ;;
- -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
- | --includ=* | --inclu=* | --incl=* | --inc=*)
- includedir="$ac_optarg" ;;
-
- -infodir | --infodir | --infodi | --infod | --info | --inf)
- ac_prev=infodir ;;
- -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
- infodir="$ac_optarg" ;;
-
- -libdir | --libdir | --libdi | --libd)
- ac_prev=libdir ;;
- -libdir=* | --libdir=* | --libdi=* | --libd=*)
- libdir="$ac_optarg" ;;
-
- -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
- | --libexe | --libex | --libe)
- ac_prev=libexecdir ;;
- -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
- | --libexe=* | --libex=* | --libe=*)
- libexecdir="$ac_optarg" ;;
-
- -localstatedir | --localstatedir | --localstatedi | --localstated \
- | --localstate | --localstat | --localsta | --localst \
- | --locals | --local | --loca | --loc | --lo)
- ac_prev=localstatedir ;;
- -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
- | --localstate=* | --localstat=* | --localsta=* | --localst=* \
- | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
- localstatedir="$ac_optarg" ;;
-
- -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
- ac_prev=mandir ;;
- -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
- mandir="$ac_optarg" ;;
-
- -nfp | --nfp | --nf)
- # Obsolete; use --without-fp.
- with_fp=no ;;
-
- -no-create | --no-create | --no-creat | --no-crea | --no-cre \
- | --no-cr | --no-c)
- no_create=yes ;;
-
- -no-recursion | --no-recursion | --no-recursio | --no-recursi \
- | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
- no_recursion=yes ;;
-
- -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
- | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
- | --oldin | --oldi | --old | --ol | --o)
- ac_prev=oldincludedir ;;
- -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
- | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
- | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
- oldincludedir="$ac_optarg" ;;
-
- -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
- ac_prev=prefix ;;
- -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
- prefix="$ac_optarg" ;;
-
- -program-prefix | --program-prefix | --program-prefi | --program-pref \
- | --program-pre | --program-pr | --program-p)
- ac_prev=program_prefix ;;
- -program-prefix=* | --program-prefix=* | --program-prefi=* \
- | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
- program_prefix="$ac_optarg" ;;
-
- -program-suffix | --program-suffix | --program-suffi | --program-suff \
- | --program-suf | --program-su | --program-s)
- ac_prev=program_suffix ;;
- -program-suffix=* | --program-suffix=* | --program-suffi=* \
- | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
- program_suffix="$ac_optarg" ;;
-
- -program-transform-name | --program-transform-name \
- | --program-transform-nam | --program-transform-na \
- | --program-transform-n | --program-transform- \
- | --program-transform | --program-transfor \
- | --program-transfo | --program-transf \
- | --program-trans | --program-tran \
- | --progr-tra | --program-tr | --program-t)
- ac_prev=program_transform_name ;;
- -program-transform-name=* | --program-transform-name=* \
- | --program-transform-nam=* | --program-transform-na=* \
- | --program-transform-n=* | --program-transform-=* \
- | --program-transform=* | --program-transfor=* \
- | --program-transfo=* | --program-transf=* \
- | --program-trans=* | --program-tran=* \
- | --progr-tra=* | --program-tr=* | --program-t=*)
- program_transform_name="$ac_optarg" ;;
-
- -q | -quiet | --quiet | --quie | --qui | --qu | --q \
- | -silent | --silent | --silen | --sile | --sil)
- silent=yes ;;
-
- -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
- ac_prev=sbindir ;;
- -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
- | --sbi=* | --sb=*)
- sbindir="$ac_optarg" ;;
-
- -sharedstatedir | --sharedstatedir | --sharedstatedi \
- | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
- | --sharedst | --shareds | --shared | --share | --shar \
- | --sha | --sh)
- ac_prev=sharedstatedir ;;
- -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
- | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
- | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
- | --sha=* | --sh=*)
- sharedstatedir="$ac_optarg" ;;
-
- -site | --site | --sit)
- ac_prev=site ;;
- -site=* | --site=* | --sit=*)
- site="$ac_optarg" ;;
-
- -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
- ac_prev=srcdir ;;
- -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
- srcdir="$ac_optarg" ;;
-
- -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
- | --syscon | --sysco | --sysc | --sys | --sy)
- ac_prev=sysconfdir ;;
- -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
- | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
- sysconfdir="$ac_optarg" ;;
-
- -target | --target | --targe | --targ | --tar | --ta | --t)
- ac_prev=target ;;
- -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
- target="$ac_optarg" ;;
-
- -v | -verbose | --verbose | --verbos | --verbo | --verb)
- verbose=yes ;;
-
- -version | --version | --versio | --versi | --vers)
- echo "configure generated by autoconf version 2.12"
- exit 0 ;;
-
- -with-* | --with-*)
- ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then
- { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
- fi
- ac_package=`echo $ac_package| sed 's/-/_/g'`
- case "$ac_option" in
- *=*) ;;
- *) ac_optarg=yes ;;
- esac
- eval "with_${ac_package}='$ac_optarg'" ;;
-
- -without-* | --without-*)
- ac_package=`echo $ac_option|sed -e 's/-*without-//'`
- # Reject names that are not valid shell variable names.
- if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then
- { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
- fi
- ac_package=`echo $ac_package| sed 's/-/_/g'`
- eval "with_${ac_package}=no" ;;
-
- --x)
- # Obsolete; use --with-x.
- with_x=yes ;;
-
- -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
- | --x-incl | --x-inc | --x-in | --x-i)
- ac_prev=x_includes ;;
- -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
- | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
- x_includes="$ac_optarg" ;;
-
- -x-libraries | --x-libraries | --x-librarie | --x-librari \
- | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
- ac_prev=x_libraries ;;
- -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
- | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
- x_libraries="$ac_optarg" ;;
-
- -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; }
- ;;
-
- *)
- if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then
- echo "configure: warning: $ac_option: invalid host type" 1>&2
- fi
- if test "x$nonopt" != xNONE; then
- { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; }
- fi
- nonopt="$ac_option"
- ;;
-
- esac
-done
-
-if test -n "$ac_prev"; then
- { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; }
-fi
-
-trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
-
-# File descriptor usage:
-# 0 standard input
-# 1 file creation
-# 2 errors and warnings
-# 3 some systems may open it to /dev/tty
-# 4 used on the Kubota Titan
-# 6 checking for... messages and results
-# 5 compiler messages saved in config.log
-if test "$silent" = yes; then
- exec 6>/dev/null
-else
- exec 6>&1
-fi
-exec 5>./config.log
-
-echo "\
-This file contains any messages produced by compilers while
-running configure, to aid debugging if configure makes a mistake.
-" 1>&5
-
-# Strip out --no-create and --no-recursion so they do not pile up.
-# Also quote any args containing shell metacharacters.
-ac_configure_args=
-for ac_arg
-do
- case "$ac_arg" in
- -no-create | --no-create | --no-creat | --no-crea | --no-cre \
- | --no-cr | --no-c) ;;
- -no-recursion | --no-recursion | --no-recursio | --no-recursi \
- | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;;
- *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*)
- ac_configure_args="$ac_configure_args '$ac_arg'" ;;
- *) ac_configure_args="$ac_configure_args $ac_arg" ;;
- esac
-done
-
-# NLS nuisances.
-# Only set these to C if already set. These must not be set unconditionally
-# because not all systems understand e.g. LANG=C (notably SCO).
-# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'!
-# Non-C LC_CTYPE values break the ctype check.
-if test "${LANG+set}" = set; then LANG=C; export LANG; fi
-if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
-if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi
-if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi
-
-# confdefs.h avoids OS command line length limits that DEFS can exceed.
-rm -rf conftest* confdefs.h
-# AIX cpp loses on an empty file, so make sure it contains at least a newline.
-echo > confdefs.h
-
-# A filename unique to this package, relative to the directory that
-# configure is in, which we can look for to find out if srcdir is correct.
-ac_unique_file=boot-9.scm
-
-# Find the source files, if location was not specified.
-if test -z "$srcdir"; then
- ac_srcdir_defaulted=yes
- # Try the directory containing this script, then its parent.
- ac_prog=$0
- ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'`
- test "x$ac_confdir" = "x$ac_prog" && ac_confdir=.
- srcdir=$ac_confdir
- if test ! -r $srcdir/$ac_unique_file; then
- srcdir=..
- fi
-else
- ac_srcdir_defaulted=no
-fi
-if test ! -r $srcdir/$ac_unique_file; then
- if test "$ac_srcdir_defaulted" = yes; then
- { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; }
- else
- { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; }
- fi
-fi
-srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'`
-
-# Prefer explicitly selected file to automatically selected ones.
-if test -z "$CONFIG_SITE"; then
- if test "x$prefix" != xNONE; then
- CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
- else
- CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
- fi
-fi
-for ac_site_file in $CONFIG_SITE; do
- if test -r "$ac_site_file"; then
- echo "loading site script $ac_site_file"
- . "$ac_site_file"
- fi
-done
-
-if test -r "$cache_file"; then
- echo "loading cache $cache_file"
- . $cache_file
-else
- echo "creating cache $cache_file"
- > $cache_file
-fi
-
-ac_ext=c
-# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
-ac_cpp='$CPP $CPPFLAGS'
-ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
-ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
-cross_compiling=$ac_cv_prog_cc_cross
-
-if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
- # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
- if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then
- ac_n= ac_c='
-' ac_t=' '
- else
- ac_n=-n ac_c= ac_t=
- fi
-else
- ac_n= ac_c='\c' ac_t=
-fi
-
-
-ac_aux_dir=
-for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do
- if test -f $ac_dir/install-sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install-sh -c"
- break
- elif test -f $ac_dir/install.sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install.sh -c"
- break
- fi
-done
-if test -z "$ac_aux_dir"; then
- { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; }
-fi
-ac_config_guess=$ac_aux_dir/config.guess
-ac_config_sub=$ac_aux_dir/config.sub
-ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
-
-# Find a good install program. We prefer a C program (faster),
-# so one script is as good as another. But avoid the broken or
-# incompatible versions:
-# SysV /etc/install, /usr/sbin/install
-# SunOS /usr/etc/install
-# IRIX /sbin/install
-# AIX /bin/install
-# AFS /usr/afsws/bin/install, which mishandles nonexistent args
-# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
-# ./install, which can be erroneously created by make from ./install.sh.
-echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6
-echo "configure:552: checking for a BSD compatible install" >&5
-if test -z "$INSTALL"; then
-if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS="${IFS}:"
- for ac_dir in $PATH; do
- # Account for people who put trailing slashes in PATH elements.
- case "$ac_dir/" in
- /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;;
- *)
- # OSF1 and SCO ODT 3.0 have their own names for install.
- for ac_prog in ginstall installbsd scoinst install; do
- if test -f $ac_dir/$ac_prog; then
- if test $ac_prog = install &&
- grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then
- # AIX install. It has an incompatible calling convention.
- # OSF/1 installbsd also uses dspmsg, but is usable.
- :
- else
- ac_cv_path_install="$ac_dir/$ac_prog -c"
- break 2
- fi
- fi
- done
- ;;
- esac
- done
- IFS="$ac_save_IFS"
-
-fi
- if test "${ac_cv_path_install+set}" = set; then
- INSTALL="$ac_cv_path_install"
- else
- # As a last resort, use the slow shell script. We don't cache a
- # path for INSTALL within a source directory, because that will
- # break other packages using the cache if that directory is
- # removed, or if the path is relative.
- INSTALL="$ac_install_sh"
- fi
-fi
-echo "$ac_t""$INSTALL" 1>&6
-
-# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
-# It thinks the first close brace ends the variable substitution.
-test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
-
-test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
-
-
-test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
-
-
-. $srcdir/../GUILE-VERSION
-
-PACKAGE=$PACKAGE
-
-cat >> confdefs.h <<EOF
-#define PACKAGE "$PACKAGE"
-EOF
-
-VERSION=$VERSION
-
-cat >> confdefs.h <<EOF
-#define VERSION "$VERSION"
-EOF
-
-echo $ac_n "checking whether build environment is sane""... $ac_c" 1>&6
-echo "configure:620: checking whether build environment is sane" >&5
-echo timestamp > conftestfile
-# Do this in a subshell so we don't clobber the current shell's
-# arguments. FIXME: maybe try `-L' hack like GETLOADAVG test?
-if (set X `ls -t $srcdir/configure conftestfile`; test "$2" = conftestfile)
-then
- # Ok.
- :
-else
- { echo "configure: error: newly created file is older than distributed files!
-Check your system clock" 1>&2; exit 1; }
-fi
-rm -f conftest*
-echo "$ac_t""yes" 1>&6
-if test "$program_transform_name" = s,x,x,; then
- program_transform_name=
-else
- # Double any \ or $. echo might interpret backslashes.
- cat <<\EOF_SED > conftestsed
-s,\\,\\\\,g; s,\$,$$,g
-EOF_SED
- program_transform_name="`echo $program_transform_name|sed -f conftestsed`"
- rm -f conftestsed
-fi
-test "$program_prefix" != NONE &&
- program_transform_name="s,^,${program_prefix},; $program_transform_name"
-# Use a double $ so make ignores it.
-test "$program_suffix" != NONE &&
- program_transform_name="s,\$\$,${program_suffix},; $program_transform_name"
-
-# sed with no file args requires a program.
-test "$program_transform_name" = "" && program_transform_name="s,x,x,"
-
-echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
-echo "configure:654: checking whether ${MAKE-make} sets \${MAKE}" >&5
-set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
-if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftestmake <<\EOF
-all:
- @echo 'ac_maketemp="${MAKE}"'
-EOF
-# GNU make sometimes prints "make[1]: Entering...", which would confuse us.
-eval `${MAKE-make} -f conftestmake 2>/dev/null | grep temp=`
-if test -n "$ac_maketemp"; then
- eval ac_cv_prog_make_${ac_make}_set=yes
-else
- eval ac_cv_prog_make_${ac_make}_set=no
-fi
-rm -f conftestmake
-fi
-if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- SET_MAKE=
-else
- echo "$ac_t""no" 1>&6
- SET_MAKE="MAKE=${MAKE-make}"
-fi
-
-ac_aux_dir=
-for ac_dir in .. $srcdir/..; do
- if test -f $ac_dir/install-sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install-sh -c"
- break
- elif test -f $ac_dir/install.sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install.sh -c"
- break
- fi
-done
-if test -z "$ac_aux_dir"; then
- { echo "configure: error: can not find install-sh or install.sh in .. $srcdir/.." 1>&2; exit 1; }
-fi
-ac_config_guess=$ac_aux_dir/config.guess
-ac_config_sub=$ac_aux_dir/config.sub
-ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
-
-module=ice-9
-
-trap '' 1 2 15
-cat > confcache <<\EOF
-# This file is a shell script that caches the results of configure
-# tests run on this system so they can be shared between configure
-# scripts and configure runs. It is not useful on other systems.
-# If it contains results you don't want to keep, you may remove or edit it.
-#
-# By default, configure uses ./config.cache as the cache file,
-# creating it if it does not exist already. You can give configure
-# the --cache-file=FILE option to use a different cache file; that is
-# what configure does when it calls configure scripts in
-# subdirectories, so they share the cache.
-# Giving --cache-file=/dev/null disables caching, for debugging configure.
-# config.status only pays attention to the cache file if you give it the
-# --recheck option to rerun configure.
-#
-EOF
-# The following way of writing the cache mishandles newlines in values,
-# but we know of no workaround that is simple, portable, and efficient.
-# So, don't put newlines in cache variables' values.
-# Ultrix sh set writes to stderr and can't be redirected directly,
-# and sets the high bit in the cache file unless we assign to the vars.
-(set) 2>&1 |
- case `(ac_space=' '; set) 2>&1` in
- *ac_space=\ *)
- # `set' does not quote correctly, so add quotes (double-quote substitution
- # turns \\\\ into \\, and sed turns \\ into \).
- sed -n \
- -e "s/'/'\\\\''/g" \
- -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p"
- ;;
- *)
- # `set' quotes correctly as required by POSIX, so do not add quotes.
- sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p'
- ;;
- esac >> confcache
-if cmp -s $cache_file confcache; then
- :
-else
- if test -w $cache_file; then
- echo "updating cache $cache_file"
- cat confcache > $cache_file
- else
- echo "not updating unwritable cache $cache_file"
- fi
-fi
-rm -f confcache
-
-trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
-
-test "x$prefix" = xNONE && prefix=$ac_default_prefix
-# Let make expand exec_prefix.
-test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
-
-# Any assignment to VPATH causes Sun make to only execute
-# the first set of double-colon rules, so remove it if not needed.
-# If there is a colon in the path, we need to keep it.
-if test "x$srcdir" = x.; then
- ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d'
-fi
-
-trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15
-
-# Transform confdefs.h into DEFS.
-# Protect against shell expansion while executing Makefile rules.
-# Protect against Makefile macro expansion.
-cat > conftest.defs <<\EOF
-s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g
-s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g
-s%\[%\\&%g
-s%\]%\\&%g
-s%\$%$$%g
-EOF
-DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '`
-rm -f conftest.defs
-
-
-# Without the "./", some shells look in PATH for config.status.
-: ${CONFIG_STATUS=./config.status}
-
-echo creating $CONFIG_STATUS
-rm -f $CONFIG_STATUS
-cat > $CONFIG_STATUS <<EOF
-#! /bin/sh
-# Generated automatically by configure.
-# Run this file to recreate the current configuration.
-# This directory was configured as follows,
-# on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
-#
-# $0 $ac_configure_args
-#
-# Compiler output produced by configure, useful for debugging
-# configure, is in ./config.log if it exists.
-
-ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]"
-for ac_option
-do
- case "\$ac_option" in
- -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
- echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
- exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
- -version | --version | --versio | --versi | --vers | --ver | --ve | --v)
- echo "$CONFIG_STATUS generated by autoconf version 2.12"
- exit 0 ;;
- -help | --help | --hel | --he | --h)
- echo "\$ac_cs_usage"; exit 0 ;;
- *) echo "\$ac_cs_usage"; exit 1 ;;
- esac
-done
-
-ac_given_srcdir=$srcdir
-ac_given_INSTALL="$INSTALL"
-
-trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
-EOF
-cat >> $CONFIG_STATUS <<EOF
-
-# Protect against being on the right side of a sed subst in config.status.
-sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g;
- s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF
-$ac_vpsub
-$extrasub
-s%@CFLAGS@%$CFLAGS%g
-s%@CPPFLAGS@%$CPPFLAGS%g
-s%@CXXFLAGS@%$CXXFLAGS%g
-s%@DEFS@%$DEFS%g
-s%@LDFLAGS@%$LDFLAGS%g
-s%@LIBS@%$LIBS%g
-s%@exec_prefix@%$exec_prefix%g
-s%@prefix@%$prefix%g
-s%@program_transform_name@%$program_transform_name%g
-s%@bindir@%$bindir%g
-s%@sbindir@%$sbindir%g
-s%@libexecdir@%$libexecdir%g
-s%@datadir@%$datadir%g
-s%@sysconfdir@%$sysconfdir%g
-s%@sharedstatedir@%$sharedstatedir%g
-s%@localstatedir@%$localstatedir%g
-s%@libdir@%$libdir%g
-s%@includedir@%$includedir%g
-s%@oldincludedir@%$oldincludedir%g
-s%@infodir@%$infodir%g
-s%@mandir@%$mandir%g
-s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g
-s%@INSTALL_DATA@%$INSTALL_DATA%g
-s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g
-s%@PACKAGE@%$PACKAGE%g
-s%@VERSION@%$VERSION%g
-s%@SET_MAKE@%$SET_MAKE%g
-s%@module@%$module%g
-
-CEOF
-EOF
-
-cat >> $CONFIG_STATUS <<\EOF
-
-# Split the substitutions into bite-sized pieces for seds with
-# small command number limits, like on Digital OSF/1 and HP-UX.
-ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script.
-ac_file=1 # Number of current file.
-ac_beg=1 # First line for current file.
-ac_end=$ac_max_sed_cmds # Line after last line for current file.
-ac_more_lines=:
-ac_sed_cmds=""
-while $ac_more_lines; do
- if test $ac_beg -gt 1; then
- sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file
- else
- sed "${ac_end}q" conftest.subs > conftest.s$ac_file
- fi
- if test ! -s conftest.s$ac_file; then
- ac_more_lines=false
- rm -f conftest.s$ac_file
- else
- if test -z "$ac_sed_cmds"; then
- ac_sed_cmds="sed -f conftest.s$ac_file"
- else
- ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file"
- fi
- ac_file=`expr $ac_file + 1`
- ac_beg=$ac_end
- ac_end=`expr $ac_end + $ac_max_sed_cmds`
- fi
-done
-if test -z "$ac_sed_cmds"; then
- ac_sed_cmds=cat
-fi
-EOF
-
-cat >> $CONFIG_STATUS <<EOF
-
-CONFIG_FILES=\${CONFIG_FILES-"Makefile"}
-EOF
-cat >> $CONFIG_STATUS <<\EOF
-for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
- # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
- case "$ac_file" in
- *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'`
- ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
- *) ac_file_in="${ac_file}.in" ;;
- esac
-
- # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories.
-
- # Remove last slash and all that follows it. Not all systems have dirname.
- ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
- if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
- # The file is in a subdirectory.
- test ! -d "$ac_dir" && mkdir "$ac_dir"
- ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`"
- # A "../" for each directory in $ac_dir_suffix.
- ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'`
- else
- ac_dir_suffix= ac_dots=
- fi
-
- case "$ac_given_srcdir" in
- .) srcdir=.
- if test -z "$ac_dots"; then top_srcdir=.
- else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;;
- /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;;
- *) # Relative path.
- srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix"
- top_srcdir="$ac_dots$ac_given_srcdir" ;;
- esac
-
- case "$ac_given_INSTALL" in
- [/$]*) INSTALL="$ac_given_INSTALL" ;;
- *) INSTALL="$ac_dots$ac_given_INSTALL" ;;
- esac
-
- echo creating "$ac_file"
- rm -f "$ac_file"
- configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
- case "$ac_file" in
- *Makefile*) ac_comsub="1i\\
-# $configure_input" ;;
- *) ac_comsub= ;;
- esac
-
- ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
- sed -e "$ac_comsub
-s%@configure_input@%$configure_input%g
-s%@srcdir@%$srcdir%g
-s%@top_srcdir@%$top_srcdir%g
-s%@INSTALL@%$INSTALL%g
-" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file
-fi; done
-rm -f conftest.s*
-
-EOF
-cat >> $CONFIG_STATUS <<EOF
-
-EOF
-cat >> $CONFIG_STATUS <<\EOF
-
-exit 0
-EOF
-chmod +x $CONFIG_STATUS
-rm -fr confdefs* $ac_clean_files
-test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
-
diff --git a/ice-9/configure.in b/ice-9/configure.in
deleted file mode 100644
index b2d4c334b..000000000
--- a/ice-9/configure.in
+++ /dev/null
@@ -1,7 +0,0 @@
-#
-# Process this file with autoconf to produce a configure script.
-#
-
-AC_INIT(boot-9.scm)
-AM_INIT_GUILE_MODULE(ice-9)
-AC_OUTPUT(Makefile)
diff --git a/ice-9/debug.scm b/ice-9/debug.scm
deleted file mode 100644
index 20e67f9cf..000000000
--- a/ice-9/debug.scm
+++ /dev/null
@@ -1,120 +0,0 @@
-;;;; Copyright (C) 1996 Mikael Djurfeldt
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-;;;; The author can be reached at djurfeldt@nada.kth.se
-;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
-;;;;
-
-
-(define-module #/ice-9/debug)
-
-
-
-;;; {Run-time options}
-
-(define names '((debug-options-interface
- (debug-options debug-enable debug-disable)
- (debug-set!))
-
- (evaluator-traps-interface
- (traps trap-enable trap-disable)
- (trap-set!))
-
- (read-options-interface
- (read-options read-enable read-disable)
- (read-set!))
-
- (print-options-interface
- (print-options print-enable print-disable)
- (print-set!))
- ))
-
-(define option-name car)
-(define option-value cadr)
-(define option-documentation caddr)
-
-(define (print-option option)
- (display (option-name option))
- (if (< (string-length (symbol->string (option-name option))) 8)
- (display #\tab))
- (display #\tab)
- (display (option-value option))
- (display #\tab)
- (display (option-documentation option))
- (newline))
-
-;;; Below follows the macros defining the run-time option interfaces.
-;;; *fixme* These should not be macros, but need to be until module
-;;; system is improved.
-;;;
-
-(define (make-options interface)
- `(lambda args
- (cond ((null? args) (,interface))
- ((pair? (car args)) (,interface (car args)) (,interface))
- (else (for-each print-option (,interface #t))))))
-
-(define (make-enable interface)
- `(lambda flags
- (,interface (append flags (,interface)))
- (,interface)))
-
-(define (make-disable interface)
- `(lambda flags
- (let ((options (,interface)))
- (for-each (lambda (flag)
- (set! options (delq! flag options)))
- flags)
- (,interface options)
- (,interface))))
-
-(define (make-set! interface)
- `((name exp)
- (,'quasiquote
- (begin (,interface (append (,interface)
- (list '(,'unquote name)
- (,'unquote exp))))
- (,interface)))))
-
-(defmacro define-all ()
- (cons 'begin
- (apply append
- (map (lambda (group)
- (let ((interface (car group)))
- (append (map (lambda (name constructor)
- `(define-public ,name
- ,(constructor interface)))
- (cadr group)
- (list make-options
- make-enable
- make-disable))
- (map (lambda (name constructor)
- `(defmacro-public ,name
- ,@(constructor interface)))
- (caddr group)
- (list make-set!)))))
- names))))
-
-(define-all)
-
-
-
-;;; A fix to get the error handling working together with the module system.
-;;;
-(variable-set! (builtin-variable 'debug-options) debug-options)
-
-(debug-enable 'debug)
-(read-enable 'positions)
diff --git a/ice-9/expect.scm b/ice-9/expect.scm
deleted file mode 100644
index 6d25c8ba3..000000000
--- a/ice-9/expect.scm
+++ /dev/null
@@ -1,125 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-;;; Expect: a macro for selecting actions based on what it reads from a port.
-;;; The idea is from Don Libes' expect based on Tcl.
-;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
-
-
-(define expect-port #f)
-(define expect-timeout #f)
-(define expect-timeout-proc #f)
-(define expect-eof-proc #f)
-(define expect-char-proc #f)
-
-;;; expect: each test is a procedure which is applied to the accumulating
-;;; string.
-(defmacro expect clauses
- (let ((s (gentemp))
- (c (gentemp))
- (port (gentemp))
- (timeout (gentemp)))
- `(let ((,s "")
- (,port (or expect-port (current-input-port)))
- (,timeout (if expect-timeout
- (+ (* expect-timeout internal-time-units-per-second)
- (get-internal-real-time))
- #f)))
- (let next-char ()
- (if (and expect-timeout
- (or (>= (get-internal-real-time) ,timeout)
- (and (not (char-ready? ,port))
- (not (expect-select ,port ,timeout)))))
- (if expect-timeout-proc
- (expect-timeout-proc ,s)
- #f)
- (let ((,c (read-char ,port)))
- (if expect-char-proc
- (expect-char-proc ,c))
- (cond ((eof-object? ,c)
- (if expect-eof-proc
- (expect-eof-proc ,s)
- #f))
- (else
- (set! ,s (string-append ,s (string ,c)))
- (cond
- ,@(let next-expr ((tests (map car clauses))
- (exprs (map cdr clauses))
- (body ()))
- (cond
- ((null? tests)
- (reverse body))
- (else
- (next-expr
- (cdr tests)
- (cdr exprs)
- (cons
- `((,(car tests) ,s)
- ,@(cond ((null? (car exprs))
- ())
- ((eq? (caar exprs) '=>)
- (if (not (= (length (car exprs))
- 2))
- (scm-error 'misc-error
- "expect"
- "bad recipient: %S"
- (list (car exprs))
- #f)
- `((apply ,(cadar exprs)
- (,(car tests) ,s)))))
- (else
- (car exprs))))
- body)))))
- (else (next-char)))))))))))
-
-;;; the regexec front-end to expect:
-;;; each test must evaluate to a regular expression.
-(defmacro expect-strings clauses
- `(let ,@(let next-test ((tests (map car clauses))
- (exprs (map cdr clauses))
- (defs ())
- (body ()))
- (cond ((null? tests)
- (list (reverse defs) `(expect ,@(reverse body))))
- (else
- (let ((rxname (gentemp)))
- (next-test (cdr tests)
- (cdr exprs)
- (cons `(,rxname (regcomp ,(car tests)
- REG_NEWLINE))
- defs)
- (cons `((lambda (s)
- (regexec ,rxname s ""))
- ,@(car exprs))
- body))))))))
-
-;;; simplified select: returns #t if input is waiting or #f if timed out.
-;;; timeout is absolute in terms of get-internal-real-time.
-(define (expect-select port timeout)
- (let* ((relative (- timeout (get-internal-real-time)))
- (relative-s (inexact->exact
- (floor (/ relative internal-time-units-per-second))))
- (relative-ms (inexact->exact
- (round (/ (* (- relative relative-s) 1000)
- internal-time-units-per-second)))))
- (and (> relative 0)
- (pair? (car (select (list port) () ()
- relative-s
- relative-ms))))))
diff --git a/ice-9/hcons.scm b/ice-9/hcons.scm
deleted file mode 100644
index febd5e8c7..000000000
--- a/ice-9/hcons.scm
+++ /dev/null
@@ -1,76 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-(define-module #/ice-9/hcons)
-
-
-;;; {Eq? hash-consing}
-;;;
-;;; A hash conser maintains a private universe of pairs s.t. if
-;;; two cons calls pass eq? arguments, the pairs returned are eq?.
-;;;
-;;; A hash conser does not contribute life to the pairs it returns.
-;;;
-
-(define-public (hashq-cons-hash pair n)
- (modulo (logxor (hashq (car pair) 4194303)
- (hashq (cdr pair) 4194303))
- n))
-
-(define-public (hashq-cons-assoc key l)
- (and l (or (and (pair? l)
- (pair? (car l))
- (pair? (caar l))
- (eq? (car key) (caaar l))
- (eq? (cdr key) (cdaar l))
- (car l))
- (hashq-cons-assoc key (cdr l)))))
-
-(define-public (hashq-cons-get-handle table key)
- (hashx-get-handle hashq-cons-hash hashq-cons-assoc table key #f))
-
-(define-public (hashq-cons-create-handle! table key init)
- (hashx-create-handle! hashq-cons-hash hashq-cons-assoc table key init))
-
-(define-public (hashq-cons-ref table key)
- (hashx-ref hashq-cons-hash hashq-cons-assoc table key #f))
-
-(define-public (hashq-cons-set! table key val)
- (hashx-set! hashq-cons-hash hashq-cons-assoc table key val))
-
-(define-public (hashq-cons table a d)
- (car (hashq-cons-create-handle! table (cons a d) #f)))
-
-(define-public (hashq-conser hash-tab-or-size)
- (let ((table (if (vector? hash-tab-or-size)
- hash-tab-or-size
- (make-doubly-weak-hash-table hash-tab-or-size))))
- (lambda (a d) (hashq-cons table a d))))
-
-
-
-
-(define-public (make-gc-buffer n)
- (let ((ring (make-list n #f)))
- (append! ring ring)
- (lambda (next)
- (set-car! ring next)
- (set! ring (cdr ring))
- next)))
diff --git a/ice-9/lineio.scm b/ice-9/lineio.scm
deleted file mode 100644
index ffde88608..000000000
--- a/ice-9/lineio.scm
+++ /dev/null
@@ -1,112 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-
-(define-module #/ice-9/lineio)
-
-
-;;; {Line Buffering Input Ports}
-;;;
-;;; [This is a work-around to get past certain deficiencies in the capabilities
-;;; of ports. Eventually, ports should be fixed and this module nuked.]
-;;;
-;;; A line buffering input port supports:
-;;;
-;;; read-string which returns the next line of input
-;;; unread-string which pushes a line back onto the stream
-;;;
-;;; Normally a "line" is all characters up to and including a newline.
-;;; If lines are put back using unread-string, they can be broken arbitrarily
-;;; -- that is, read-string returns strings passed to unread-string (or
-;;; shared substrings of them).
-;;;
-
-;; read-string port
-;; unread-string port str
-;; Read (or buffer) a line from PORT.
-;;
-;; Not all ports support these functions -- only those with
-;; 'unread-string and 'read-string properties, bound to hooks
-;; implementing these functions.
-;;
-(define-public (unread-string str line-buffering-input-port)
- ((object-property line-buffering-input-port 'unread-string) str))
-
-;;
-(define-public (read-string line-buffering-input-port)
- ((object-property line-buffering-input-port 'read-string)))
-
-
-(define-public (lineio-port? port)
- (not (not (object-property port 'read-string))))
-
-;; make-line-buffering-input-port port
-;; Return a wrapper for PORT. The wrapper handles read-string/unread-string.
-;;
-;; The port returned by this function reads newline terminated lines from PORT.
-;; It buffers these characters internally, and parsels them out via calls
-;; to read-char, read-string, and unread-string.
-;;
-
-(define-public (make-line-buffering-input-port underlying-port)
- (let* (;; buffers - a list of strings put back by unread-string or cached
- ;; using read-line.
- ;;
- (buffers '())
-
- ;; getc - return the next character from a buffer or from the underlying
- ;; port.
- ;;
- (getc (lambda ()
- (if (not buffers)
- (read-char underlying-port)
- (let ((c (string-ref (car buffers))))
- (if (= 1 (string-length (car buffers)))
- (set! buffers (cdr buffers))
- (set-car! buffers (make-shared-substring (car buffers) 1)))
- c))))
-
- (propogate-close (lambda () (close-port underlying-port)))
-
- (self (make-soft-port (vector #f #f #f getc propogate-close) "r"))
-
- (unread-string (lambda (str)
- (and (< 0 (string-length str))
- (if (ungetc-char-ready? self)
- (set! buffers (append! (list str (string (read-char self))) buffers))
- (set! buffers (cons str buffers))))))
-
- (read-string (lambda ()
- (cond
- (buffers (let ((answer (car buffers)))
- (set! buffers (cdr buffers))
- answer))
-
- ((ungetc-char-ready? self) (read-line self 'include-newline))
-
- (else (read-line underlying-port 'include-newline)))))
-
- )
-
- (set-object-property! self 'unread-string unread-string)
- (set-object-property! self 'read-string read-string)
- self))
-
-
diff --git a/ice-9/mapping.scm b/ice-9/mapping.scm
deleted file mode 100644
index ceb3a1b38..000000000
--- a/ice-9/mapping.scm
+++ /dev/null
@@ -1,121 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-
-(define-module #/ice-9/mapping
- :use-module #/ice-9/poe)
-
-(define-public mapping-hooks-type (make-record-type 'mapping-hooks '(get-handle
- create-handle
- remove)))
-
-
-(define-public make-mapping-hooks (perfect-funcq 17 (record-constructor mapping-hooks-type)))
-(define-public mapping-hooks? (record-predicate mapping-hooks-type))
-(define-public mapping-hooks-get-handle (record-accessor mapping-hooks-type 'get-handle))
-(define-public mapping-hooks-create-handle (record-accessor mapping-hooks-type 'create-handle))
-(define-public mapping-hooks-remove (record-accessor mapping-hooks-type 'remove))
-
-(define-public mapping-type (make-record-type 'mapping '(hooks data)))
-(define-public make-mapping (record-constructor mapping-type))
-(define-public mapping? (record-predicate mapping-type))
-(define-public mapping-hooks (record-accessor mapping-type 'hooks))
-(define-public mapping-data (record-accessor mapping-type 'data))
-(define-public set-mapping-hooks! (record-modifier mapping-type 'hooks))
-(define-public set-mapping-data! (record-modifier mapping-type 'data))
-
-(define-public (mapping-get-handle map key)
- ((mapping-hooks-get-handle (mapping-hooks map)) map key))
-(define-public (mapping-create-handle! map key . opts)
- (apply (mapping-hooks-create-handle (mapping-hooks map)) map key opts))
-(define-public (mapping-remove! map key)
- ((mapping-hooks-remove (mapping-hooks map)) map key))
-
-(define-public (mapping-ref map key . dflt)
- (cond
- ((mapping-get-handle map key) => cdr)
- (dflt => car)
- (else #f)))
-
-(define-public (mapping-set! map key val)
- (set-cdr! (mapping-create-handle! map key #f) val))
-
-
-
-(define-public hash-table-mapping-hooks
- (let ((wrap (lambda (proc) (lambda (1st . rest) (apply proc (mapping-data 1st) rest)))))
-
- (perfect-funcq 17
- (lambda (hash-proc assoc-proc delete-proc)
- (let ((procs (list hash-proc assoc-proc delete-proc)))
- (cond
- ((equal? procs `(,hashq ,assq ,delq!))
- (make-mapping-hooks (wrap hashq-get-handle)
- (wrap hashq-create-handle!)
- (wrap hashq-remove!)))
- ((equal? procs `(,hashv ,assv ,delv!))
- (make-mapping-hooks (wrap hashv-get-handle)
- (wrap hashv-create-handle!)
- (wrap hashv-remove!)))
- ((equal? procs `(,hash ,assoc ,delete!))
- (make-mapping-hooks (wrap hash-get-handle)
- (wrap hash-create-handle!)
- (wrap hash-remove!)))
- (else
- (make-mapping-hooks (wrap
- (lambda (table key)
- (hashx-get-handle hash-proc assoc-proc table key)))
- (wrap
- (lambda (table key)
- (hashx-create-handle hash-proc assoc-proc table key)))
- (wrap
- (lambda (table key)
- (hashx-get-handle hash-proc assoc-proc delete-proc table key)))))))))))
-
-(define-public (make-hash-table-mapping table hash-proc assoc-proc delete-proc)
- (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc delete-proc) table))
-
-(define-public (hash-table-mapping . options)
- (let* ((size (or (and options (number? (car options)) (car options))
- 71))
- (hash-proc (or (kw-arg-ref options :hash-proc) hash))
- (assoc-proc (or (kw-arg-ref options :assoc-proc)
- (cond
- ((eq? hash-proc hash) assoc)
- ((eq? hash-proc hashv) assv)
- ((eq? hash-proc hashq) assq)
- (else (error 'hash-table-mapping
- "Hash-procedure specified with no known assoc function."
- hash-proc)))))
- (delete-proc (or (kw-arg-ref options :delete-proc)
- (cond
- ((eq? hash-proc hash) delete!)
- ((eq? hash-proc hashv) delv!)
- ((eq? hash-proc hashq) delq!)
- (else (error 'hash-table-mapping
- "Hash-procedure specified with no known delete function."
- hash-proc)))))
- (table-constructor (or (kw-arg-ref options :table-constructor)
- (lambda (len) (make-vector len '())))))
- (make-hash-table-mapping (table-constructor size)
- hash-proc
- assoc-proc
- delete-proc)))
-
diff --git a/ice-9/poe.scm b/ice-9/poe.scm
deleted file mode 100644
index eb3a13fca..000000000
--- a/ice-9/poe.scm
+++ /dev/null
@@ -1,117 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-(define-module #/ice-9/poe
- :use-module #/ice-9/hcons)
-
-
-
-
-;;; {Pure Functions}
-;;;
-;;; A pure function (of some sort) is characterized by two equality
-;;; relations: one on argument lists and one on return values.
-;;; A pure function is one that when applied to equal arguments lists
-;;; yields equal results.
-;;;
-;;; If the equality relationship on return values can be eq?, it may make
-;;; sense to cache values returned by the function. Choosing the right
-;;; equality relation on arguments is tricky.
-;;;
-
-
-;;; {pure-funcq}
-;;;
-;;; The simplest case of pure functions are those in which results
-;;; are only certainly eq? if all of the arguments are. These functions
-;;; are called "pure-funcq", for obvious reasons.
-;;;
-
-
-(define funcq-memo (make-weak-key-hash-table 523)) ; !!! randomly selected values
-(define funcq-buffer (make-gc-buffer 256))
-
-(define (funcq-hash arg-list n)
- (let ((it (let loop ((x 0)
- (arg-list arg-list))
- (if (null? arg-list)
- (modulo x n)
- (loop (logior x (hashq (car arg-list) 4194303))
- (cdr arg-list))))))
- it))
-
-(define (funcq-assoc arg-list alist)
- (let ((it (and alist
- (let and-map ((key arg-list)
- (entry (caar alist)))
- (or (and (and (not key) (not entry))
- (car alist))
- (and key entry
- (eq? (car key) (car entry))
- (and-map (cdr key) (cdr entry))))))))
- it))
-
-
-
-(define-public (pure-funcq base-func)
- (lambda args
- (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
- (if cached
- (begin
- (funcq-buffer (car cached))
- (cdr cached))
-
- (let ((val (apply base-func args))
- (key (cons base-func args)))
- (funcq-buffer key)
- (hashx-set! funcq-hash funcq-assoc funcq-memo key val)
- val)))))
-
-
-
-;;; {Perfect funq}
-;;;
-;;; A pure funq may sometimes forget its past but a perfect
-;;; funcq never does.
-;;;
-
-(define-public (perfect-funcq size base-func)
- (define funcq-memo (make-hash-table size))
-
- (lambda args
- (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
- (if cached
- (begin
- (funcq-buffer (car cached))
- (cdr cached))
-
- (let ((val (apply base-func args))
- (key (cons base-func args)))
- (funcq-buffer key)
- (hashx-set! funcq-hash funcq-assoc funcq-memo key val)
- val)))))
-
-
-
-
-
-
-
-
diff --git a/ice-9/r4rs.scm b/ice-9/r4rs.scm
deleted file mode 100644
index 696ba4059..000000000
--- a/ice-9/r4rs.scm
+++ /dev/null
@@ -1,149 +0,0 @@
-;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
-;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-
-;;;; apply and call-with-current-continuation
-
-;;; These turn syntax, @apply and @call-with-current-continuation,
-;;; into procedures. If someone knows why they have to be syntax to
-;;; begin with, please fix this comment.
-(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
-(define (call-with-current-continuation proc)
- (@call-with-current-continuation proc))
-
-
-;;;; Basic Port Code
-
-;;; Specifically, the parts of the low-level port code that are written in
-;;; Scheme rather than C.
-;;;
-;;; WARNING: the parts of this interface that refer to file ports
-;;; are going away. It would be gone already except that it is used
-;;; "internally" in a few places.
-
-
-;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the proper
-;; mode to open files in. MSDOS does carraige return - newline
-;; translation if not opened in `b' mode.
-;;
-(define OPEN_READ (case (software-type)
- ((MS-DOS WINDOWS ATARIST) "rb")
- (else "r")))
-(define OPEN_WRITE (case (software-type)
- ((MS-DOS WINDOWS ATARIST) "wb")
- (else "w")))
-(define OPEN_BOTH (case (software-type)
- ((MS-DOS WINDOWS ATARIST) "r+b")
- (else "r+")))
-
-(define *null-device* "/dev/null")
-
-(define (open-input-file str)
- (open-file str OPEN_READ))
-
-(define (open-output-file str)
- (open-file str OPEN_WRITE))
-
-(define (open-io-file str) (open-file str OPEN_BOTH))
-(define close-input-port close-port)
-(define close-output-port close-port)
-(define close-io-port close-port)
-
-(define (call-with-input-file str proc)
- (let* ((file (open-input-file str))
- (ans (proc file)))
- (close-input-port file)
- ans))
-
-(define (call-with-output-file str proc)
- (let* ((file (open-output-file str))
- (ans (proc file)))
- (close-output-port file)
- ans))
-
-(define (with-input-from-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-output-to-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-error-to-port port thunk)
- (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
- (dynamic-wind swaports thunk swaports)))
-
-(define (with-input-from-file file thunk)
- (let* ((nport (open-input-file file))
- (ans (with-input-from-port nport thunk)))
- (close-port nport)
- ans))
-
-(define (with-output-to-file file thunk)
- (let* ((nport (open-output-file file))
- (ans (with-output-to-port nport thunk)))
- (close-port nport)
- ans))
-
-(define (with-error-to-file file thunk)
- (let* ((nport (open-output-file file))
- (ans (with-error-to-port nport thunk)))
- (close-port nport)
- ans))
-
-(define (with-input-from-string string thunk)
- (call-with-input-string string
- (lambda (p) (with-input-from-port p thunk))))
-
-(define (with-output-to-string thunk)
- (call-with-output-string
- (lambda (p) (with-output-to-port p thunk))))
-
-(define (with-error-to-string thunk)
- (call-with-output-string
- (lambda (p) (with-error-to-port p thunk))))
-
-(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
-
-
-;;;; Loading
-
-(if (not (defined? '%load-verbosely))
- (define %load-verbosely #f))
-(define (assert-load-verbosity v) (set! %load-verbosely v))
-
-(define (%load-announce file)
- (if %load-verbosely
- (with-output-to-port (current-error-port)
- (lambda ()
- (display ";;; ")
- (display "loading ")
- (display file)
- (newline)
- (force-output)))))
-
-(set! %load-hook %load-announce)
-
-;;; If we load boot-9.scm, it provides a definition for this which is
-;;; more sophisticated.
-(define read-sharp #f)
-
-(define (load name)
- (start-stack 'load-stack
- (primitive-load name #t read-sharp)))
diff --git a/ice-9/slib.scm b/ice-9/slib.scm
deleted file mode 100644
index 0e717db71..000000000
--- a/ice-9/slib.scm
+++ /dev/null
@@ -1,188 +0,0 @@
-;;; installed-scm-file
-(define-module #/ice-9/slib)
-
-
-
-(define (eval-load <filename> evl)
- (if (not (file-exists? <filename>))
- (set! <filename> (string-append <filename> (scheme-file-suffix))))
- (call-with-input-file <filename>
- (lambda (port)
- (let ((old-load-pathname *load-pathname*))
- (set! *load-pathname* <filename>)
- (do ((o (read port #t read-sharp) (read port #t read-sharp)))
- ((eof-object? o))
- (evl o))
- (set! *load-pathname* old-load-pathname)))))
-
-
-
-(define slib:exit quit)
-(define slib:error error)
-(define slib:eval eval)
-(define defmacro:eval eval)
-(define logical:logand logand)
-(define logical:logior logior)
-(define logical:logxor logxor)
-(define logical:lognot lognot)
-(define logical:ash ash)
-(define logical:logcount logcount)
-(define logical:integer-length integer-length)
-(define logical:bit-extract bit-extract)
-(define logical:integer-expt integer-expt)
-(define logical:ipow-by-squaring ipow-by-squaring)
-(define slib:eval-load eval-load)
-(define slib:tab #\tab)
-(define slib:form-feed #\page)
-
-(define slib:features
- (append '(source
- eval
- abort
- alist
- defmacro
- delay
- dynamic-wind
- full-continuation
- hash
- hash-table
- line-i/o
- logical
- multiarg/and-
- multiarg-apply
- promise
- rev2-procedures
- rev4-optional-procedures
- string-port
- with-file)
-
- (if (defined? 'getenv)
- '(getenv)
- '())
-
- (if (defined? 'current-time)
- '(current-time)
- '())
-
- (if (defined? 'system)
- '(system)
- '())
-
- (if (defined? 'array?)
- '(array)
- '())
-
- (if (defined? 'char-ready?)
- '(char-ready?)
- '())
-
- (if (defined? 'array-for-each)
- '(array-for-each)
- '())
-
- (if (and (string->number "0.0") (inexact? (string->number "0.0")))
- '(inexact)
- '())
-
- (if (rational? (string->number "1/19"))
- '(rational)
- '())
-
- (if (real? (string->number "0.0"))
- '(real)
- ())
-
- (if (complex? (string->number "1+i"))
- '(complex)
- '())
-
- (let ((n (string->number "9999999999999999999999999999999")))
- (if (and n (exact? n))
- '(bignum)
- '()))))
-
-
-(define slib-module (current-module))
-
-(define (slib:load name)
- (save-module-excursion
- (lambda ()
- (set-current-module slib-module)
- (let* ((errinfo (catch 'system-error
- (lambda ()
- (basic-load name)
- #f)
- (lambda args args)))
- (errinfo (and errinfo
- (catch 'system-error
- (lambda ()
- (basic-load (string-append name ".scm"))
- #f)
- (lambda args args)))))
- (if errinfo
- (apply throw errinfo))))))
-
-(define slib:load-source slib:load)
-(define defmacro:load slib:load)
-
-(define slib-parent-dir
- (let* ((path (%search-load-path "slib/require.scm")))
- (if path
- (make-shared-substring path 0 (- (string-length path) 17))
- (error "Could not find slib/require.scm in " %load-path))))
-
-(define-public (implementation-vicinity)
- (string-append slib-parent-dir "/"))
-(define (library-vicinity)
- (string-append (implementation-vicinity) "slib/"))
-(define (scheme-implementation-type) 'guile)
-(define (scheme-implementation-version) "")
-
-(define (output-port-width . arg) 80)
-(define (output-port-height . arg) 24)
-
-;;; {Time}
-;;;
-
-(define difftime -)
-(define offset-time +)
-
-
-(define %system-define define)
-
-(define define
- (procedure->memoizing-macro
- (lambda (exp env)
- (if (= (length env) 1)
- `(define-public ,@(cdr exp))
- `(%system-define ,@(cdr exp))))))
-
-(define (software-type) 'UNIX)
-
-(slib:load (in-vicinity (library-vicinity) "require.scm"))
-
-(define-public require require:require)
-
-;; {Extensions to the require system so that the user can add new
-;; require modules easily.}
-
-(define *vicinity-table*
- (list
- (cons 'implementation (implementation-vicinity))
- (cons 'library (library-vicinity))))
-
-(define (install-require-vicinity name vicinity)
- (let ((entry (assq name *vicinity-table*)))
- (if entry
- (set-cdr! entry vicinity)
- (set! *vicinity-table*
- (acons name vicinity *vicinity-table*)))))
-
-(define (install-require-module name vicinity-name file-name)
- (let ((entry (assq name *catalog*))
- (vicinity (cdr (assq vicinity-name *vicinity-table*))))
- (let ((path-name (in-vicinity vicinity file-name)))
- (if entry
- (set-cdr! entry path-name)
- (set! *catalog*
- (acons name path-name *catalog*))))))
diff --git a/ice-9/tags.scm b/ice-9/tags.scm
deleted file mode 100644
index 58b7425b4..000000000
--- a/ice-9/tags.scm
+++ /dev/null
@@ -1,23 +0,0 @@
-;;; installed-scm-file
-
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-
-
-
-(define-module #/ice-9/tags)
-
diff --git a/ice-9/test.scm b/ice-9/test.scm
deleted file mode 100644
index aeb28ee59..000000000
--- a/ice-9/test.scm
+++ /dev/null
@@ -1,1032 +0,0 @@
-;; Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;
-;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
-;;
-;; The exception is that, if you link the GUILE library with other files
-;; to produce an executable, this does not by itself cause the
-;; resulting executable to be covered by the GNU General Public License.
-;; Your use of that executable is in no way restricted on account of
-;; linking the GUILE library code into it.
-;;
-;; This exception does not however invalidate any other reasons why
-;; the executable file might be covered by the GNU General Public License.
-;;
-;; This exception applies only to the code released by the
-;; Free Software Foundation under the name GUILE. If you copy
-;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
-;; not apply to the code that you add in this way. To avoid misleading
-;; anyone as to the status of such modified files, you must delete
-;; this exception notice from them.
-;;
-;; If you write modifications of your own for GUILE, it is your choice
-;; whether to permit this exception to apply to your modifications.
-;; If you do not wish that, delete this exception notice.
-
-;;;; "test.scm" Test correctness of scheme implementations.
-;;; Author: Aubrey Jaffer
-;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately
-;;; won't pass. Made the the tests (test-cont), (test-sc4), and
-;;; (test-delay) start to run automatically.
-
-;;; This includes examples from
-;;; William Clinger and Jonathan Rees, editors.
-;;; Revised^4 Report on the Algorithmic Language Scheme
-;;; and the IEEE specification.
-
-;;; The input tests read this file expecting it to be named
-;;; "test.scm", so you'll have to run it from the ice-9 source
-;;; directory, or copy this file elsewhere
-;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
-;;; these tests. You may need to delete them in order to run
-;;; "test.scm" more than once.
-
-;;; There are three optional tests:
-;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
-;;;
-;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
-;;;
-;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
-;;; either standard.
-
-;;; If you are testing a R3RS version which does not have `list?' do:
-;;; (define list? #f)
-
-;;; send corrections or additions to jaffer@ai.mit.edu or
-;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
-
-(define cur-section '())(define errs '())
-(define SECTION (lambda args
- (display "SECTION") (write args) (newline)
- (set! cur-section args) #t))
-(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
-
-(define test
- (lambda (expect fun . args)
- (write (cons fun args))
- (display " ==> ")
- ((lambda (res)
- (write res)
- (newline)
- (cond ((not (equal? expect res))
- (record-error (list res expect (cons fun args)))
- (display " BUT EXPECTED ")
- (write expect)
- (newline)
- #f)
- (else #t)))
- (if (procedure? fun) (apply fun args) (car args)))))
-(define (report-errs)
- (newline)
- (if (null? errs) (display "Passed all tests")
- (begin
- (display "errors were:")
- (newline)
- (display "(SECTION (got expected (call)))")
- (newline)
- (for-each (lambda (l) (write l) (newline))
- errs)))
- (newline))
-
-(SECTION 2 1);; test that all symbol characters are supported.
-'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
-
-(SECTION 3 4)
-(define disjoint-type-functions
- (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
-(define type-examples
- (list
- #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
-(define i 1)
-(for-each (lambda (x) (display (make-string i #\ ))
- (set! i (+ 3 i))
- (write x)
- (newline))
- disjoint-type-functions)
-(define type-matrix
- (map (lambda (x)
- (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
- (write t)
- (write x)
- (newline)
- t))
- type-examples))
-(SECTION 4 1 2)
-(test '(quote a) 'quote (quote 'a))
-(test '(quote a) 'quote ''a)
-(SECTION 4 1 3)
-(test 12 (if #f + *) 3 4)
-(SECTION 4 1 4)
-(test 8 (lambda (x) (+ x x)) 4)
-(define reverse-subtract
- (lambda (x y) (- y x)))
-(test 3 reverse-subtract 7 10)
-(define add4
- (let ((x 4))
- (lambda (y) (+ x y))))
-(test 10 add4 6)
-(test '(3 4 5 6) (lambda x x) 3 4 5 6)
-(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
-(SECTION 4 1 5)
-(test 'yes 'if (if (> 3 2) 'yes 'no))
-(test 'no 'if (if (> 2 3) 'yes 'no))
-(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
-(SECTION 4 1 6)
-(define x 2)
-(test 3 'define (+ x 1))
-(set! x 4)
-(test 5 'set! (+ x 1))
-(SECTION 4 2 1)
-(test 'greater 'cond (cond ((> 3 2) 'greater)
- ((< 3 2) 'less)))
-(test 'equal 'cond (cond ((> 3 3) 'greater)
- ((< 3 3) 'less)
- (else 'equal)))
-(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
- (else #f)))
-(test 'composite 'case (case (* 2 3)
- ((2 3 5 7) 'prime)
- ((1 4 6 8 9) 'composite)))
-(test 'consonant 'case (case (car '(c d))
- ((a e i o u) 'vowel)
- ((w y) 'semivowel)
- (else 'consonant)))
-(test #t 'and (and (= 2 2) (> 2 1)))
-(test #f 'and (and (= 2 2) (< 2 1)))
-(test '(f g) 'and (and 1 2 'c '(f g)))
-(test #t 'and (and))
-(test #t 'or (or (= 2 2) (> 2 1)))
-(test #t 'or (or (= 2 2) (< 2 1)))
-(test #f 'or (or #f #f #f))
-(test #f 'or (or))
-(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
-(SECTION 4 2 2)
-(test 6 'let (let ((x 2) (y 3)) (* x y)))
-(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
-(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
-(test #t 'letrec (letrec ((even?
- (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
- (odd?
- (lambda (n) (if (zero? n) #f (even? (- n 1))))))
- (even? 88)))
-(define x 34)
-(test 5 'let (let ((x 3)) (define x 5) x))
-(test 34 'let x)
-(test 6 'let (let () (define x 6) x))
-(test 34 'let x)
-(test 7 'let* (let* ((x 3)) (define x 7) x))
-(test 34 'let* x)
-(test 8 'let* (let* () (define x 8) x))
-(test 34 'let* x)
-(test 9 'letrec (letrec () (define x 9) x))
-(test 34 'letrec x)
-(test 10 'letrec (letrec ((x 3)) (define x 10) x))
-(test 34 'letrec x)
-(SECTION 4 2 3)
-(define x 0)
-(test 6 'begin (begin (set! x 5) (+ x 1)))
-(SECTION 4 2 4)
-(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
- (i 0 (+ i 1)))
- ((= i 5) vec)
- (vector-set! vec i i)))
-(test 25 'do (let ((x '(1 3 5 7 9)))
- (do ((x x (cdr x))
- (sum 0 (+ sum (car x))))
- ((null? x) sum))))
-(test 1 'let (let foo () 1))
-(test '((6 1 3) (-5 -2)) 'let
- (let loop ((numbers '(3 -2 1 6 -5))
- (nonneg '())
- (neg '()))
- (cond ((null? numbers) (list nonneg neg))
- ((negative? (car numbers))
- (loop (cdr numbers)
- nonneg
- (cons (car numbers) neg)))
- (else
- (loop (cdr numbers)
- (cons (car numbers) nonneg)
- neg)))))
-(SECTION 4 2 6)
-(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
-(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
-(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
-(test '((foo 7) . cons)
- 'quasiquote
- `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
-
-;;; sqt is defined here because not all implementations are required to
-;;; support it.
-(define (sqt x)
- (do ((i 0 (+ i 1)))
- ((> (* i i) x) (- i 1))))
-
-(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
-(test 5 'quasiquote `,(+ 2 3))
-(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
- 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
-(test '(a `(b ,x ,'y d) e) 'quasiquote
- (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
-(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
-(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
-(SECTION 5 2 1)
-(define add3 (lambda (x) (+ x 3)))
-(test 6 'define (add3 3))
-(define first car)
-(test 1 'define (first '(1 2)))
-(SECTION 5 2 2)
-(test 45 'define
- (let ((x 5))
- (define foo (lambda (y) (bar x y)))
- (define bar (lambda (a b) (+ (* a b) a)))
- (foo (+ x 3))))
-(define x 34)
-(define (foo) (define x 5) x)
-(test 5 foo)
-(test 34 'define x)
-(define foo (lambda () (define x 5) x))
-(test 5 foo)
-(test 34 'define x)
-(define (foo x) ((lambda () (define x 5) x)) x)
-(test 88 foo 88)
-(test 4 foo 4)
-(test 34 'define x)
-(SECTION 6 1)
-(test #f not #t)
-(test #f not 3)
-(test #f not (list 3))
-(test #t not #f)
-;;; Not for Guile
-;(test #f not '())
-;(test #f not (list))
-(test #f not 'nil)
-
-(test #t boolean? #f)
-(test #f boolean? 0)
-;;; Not for Guile
-;(test #f boolean? '())
-(SECTION 6 2)
-(test #t eqv? 'a 'a)
-(test #f eqv? 'a 'b)
-(test #t eqv? 2 2)
-(test #t eqv? '() '())
-(test #t eqv? '10000 '10000)
-(test #f eqv? (cons 1 2)(cons 1 2))
-(test #f eqv? (lambda () 1) (lambda () 2))
-(test #f eqv? #f 'nil)
-(let ((p (lambda (x) x)))
- (test #t eqv? p p))
-(define gen-counter
- (lambda ()
- (let ((n 0))
- (lambda () (set! n (+ n 1)) n))))
-(let ((g (gen-counter))) (test #t eqv? g g))
-(test #f eqv? (gen-counter) (gen-counter))
-(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
- (g (lambda () (if (eqv? f g) 'g 'both))))
- (test #f eqv? f g))
-
-(test #t eq? 'a 'a)
-(test #f eq? (list 'a) (list 'a))
-(test #t eq? '() '())
-(test #t eq? car car)
-(let ((x '(a))) (test #t eq? x x))
-(let ((x '#())) (test #t eq? x x))
-(let ((x (lambda (x) x))) (test #t eq? x x))
-
-(test #t equal? 'a 'a)
-(test #t equal? '(a) '(a))
-(test #t equal? '(a (b) c) '(a (b) c))
-(test #t equal? "abc" "abc")
-(test #t equal? 2 2)
-(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
-(SECTION 6 3)
-(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
-(define x (list 'a 'b 'c))
-(define y x)
-(and list? (test #t list? y))
-(set-cdr! x 4)
-(test '(a . 4) 'set-cdr! x)
-(test #t eqv? x y)
-(test '(a b c . d) 'dot '(a . (b . (c . d))))
-(and list? (test #f list? y))
-(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
-
-(test #t pair? '(a . b))
-(test #t pair? '(a . 1))
-(test #t pair? '(a b c))
-(test #f pair? '())
-(test #f pair? '#(a b))
-
-(test '(a) cons 'a '())
-(test '((a) b c d) cons '(a) '(b c d))
-(test '("a" b c) cons "a" '(b c))
-(test '(a . 3) cons 'a 3)
-(test '((a b) . c) cons '(a b) 'c)
-
-(test 'a car '(a b c))
-(test '(a) car '((a) b c d))
-(test 1 car '(1 . 2))
-
-(test '(b c d) cdr '((a) b c d))
-(test 2 cdr '(1 . 2))
-
-(test '(a 7 c) list 'a (+ 3 4) 'c)
-(test '() list)
-
-(test 3 length '(a b c))
-(test 3 length '(a (b) (c d e)))
-(test 0 length '())
-
-(test '(x y) append '(x) '(y))
-(test '(a b c d) append '(a) '(b c d))
-(test '(a (b) (c)) append '(a (b)) '((c)))
-(test '() append)
-(test '(a b c . d) append '(a b) '(c . d))
-(test 'a append '() 'a)
-
-(test '(c b a) reverse '(a b c))
-(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
-
-(test 'c list-ref '(a b c d) 2)
-
-(test '(a b c) memq 'a '(a b c))
-(test '(b c) memq 'b '(a b c))
-(test '#f memq 'a '(b c d))
-(test '#f memq (list 'a) '(b (a) c))
-(test '((a) c) member (list 'a) '(b (a) c))
-(test '(101 102) memv 101 '(100 101 102))
-
-(define e '((a 1) (b 2) (c 3)))
-(test '(a 1) assq 'a e)
-(test '(b 2) assq 'b e)
-(test #f assq 'd e)
-(test #f assq (list 'a) '(((a)) ((b)) ((c))))
-(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
-(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
-(SECTION 6 4)
-(test #t symbol? 'foo)
-(test #t symbol? (car '(a b)))
-(test #f symbol? "bar")
-(test #t symbol? 'nil)
-(test #f symbol? '())
-(test #f symbol? #f)
-;;; But first, what case are symbols in? Determine the standard case:
-(define char-standard-case char-upcase)
-(if (string=? (symbol->string 'A) "a")
- (set! char-standard-case char-downcase))
-;;; Not for Guile
-;(test #t 'standard-case
-; (string=? (symbol->string 'a) (symbol->string 'A)))
-;(test #t 'standard-case
-; (or (string=? (symbol->string 'a) "A")
-; (string=? (symbol->string 'A) "a")))
-(define (str-copy s)
- (let ((v (make-string (string-length s))))
- (do ((i (- (string-length v) 1) (- i 1)))
- ((< i 0) v)
- (string-set! v i (string-ref s i)))))
-(define (string-standard-case s)
- (set! s (str-copy s))
- (do ((i 0 (+ 1 i))
- (sl (string-length s)))
- ((>= i sl) s)
- (string-set! s i (char-standard-case (string-ref s i)))))
-;;; Not for Guile
-;(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
-;(test (string-standard-case "martin") symbol->string 'Martin)
-(test "Malvina" symbol->string (string->symbol "Malvina"))
-;;; Not for Guile
-;(test #t 'standard-case (eq? 'a 'A))
-
-(define x (string #\a #\b))
-(define y (string->symbol x))
-(string-set! x 0 #\c)
-(test "cb" 'string-set! x)
-(test "ab" symbol->string y)
-(test y string->symbol "ab")
-
-;;; Not for Guile
-;(test #t eq? 'mISSISSIppi 'mississippi)
-;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
-(test 'JollyWog string->symbol (symbol->string 'JollyWog))
-
-(SECTION 6 5 5)
-(test #t number? 3)
-(test #t complex? 3)
-(test #t real? 3)
-(test #t rational? 3)
-(test #t integer? 3)
-
-(test #t exact? 3)
-(test #f inexact? 3)
-
-(test #t = 22 22 22)
-(test #t = 22 22)
-(test #f = 34 34 35)
-(test #f = 34 35)
-(test #t > 3 -6246)
-(test #f > 9 9 -2424)
-(test #t >= 3 -4 -6246)
-(test #t >= 9 9)
-(test #f >= 8 9)
-(test #t < -1 2 3 4 5 6 7 8)
-(test #f < -1 2 3 4 4 5 6 7)
-(test #t <= -1 2 3 4 5 6 7 8)
-(test #t <= -1 2 3 4 4 5 6 7)
-(test #f < 1 3 2)
-(test #f >= 1 3 2)
-
-(test #t zero? 0)
-(test #f zero? 1)
-(test #f zero? -1)
-(test #f zero? -100)
-(test #t positive? 4)
-(test #f positive? -4)
-(test #f positive? 0)
-(test #f negative? 4)
-(test #t negative? -4)
-(test #f negative? 0)
-(test #t odd? 3)
-(test #f odd? 2)
-(test #f odd? -4)
-(test #t odd? -1)
-(test #f even? 3)
-(test #t even? 2)
-(test #t even? -4)
-(test #f even? -1)
-
-(test 38 max 34 5 7 38 6)
-(test -24 min 3 5 5 330 4 -24)
-
-(test 7 + 3 4)
-(test '3 + 3)
-(test 0 +)
-(test 4 * 4)
-(test 1 *)
-
-(test -1 - 3 4)
-(test -3 - 3)
-(test 7 abs -7)
-(test 7 abs 7)
-(test 0 abs 0)
-
-(test 5 quotient 35 7)
-(test -5 quotient -35 7)
-(test -5 quotient 35 -7)
-(test 5 quotient -35 -7)
-(test 1 modulo 13 4)
-(test 1 remainder 13 4)
-(test 3 modulo -13 4)
-(test -1 remainder -13 4)
-(test -3 modulo 13 -4)
-(test 1 remainder 13 -4)
-(test -1 modulo -13 -4)
-(test -1 remainder -13 -4)
-(define (divtest n1 n2)
- (= n1 (+ (* n2 (quotient n1 n2))
- (remainder n1 n2))))
-(test #t divtest 238 9)
-(test #t divtest -238 9)
-(test #t divtest 238 -9)
-(test #t divtest -238 -9)
-
-(test 4 gcd 0 4)
-(test 4 gcd -4 0)
-(test 4 gcd 32 -36)
-(test 0 gcd)
-(test 288 lcm 32 -36)
-(test 1 lcm)
-
-;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
-;;; Modified by jaffer.
-(define (test-inexact)
- (define f3.9 (string->number "3.9"))
- (define f4.0 (string->number "4.0"))
- (define f-3.25 (string->number "-3.25"))
- (define f.25 (string->number ".25"))
- (define f4.5 (string->number "4.5"))
- (define f3.5 (string->number "3.5"))
- (define f0.0 (string->number "0.0"))
- (define f0.8 (string->number "0.8"))
- (define f1.0 (string->number "1.0"))
- (define wto write-test-obj)
- (define dto display-test-obj)
- (define lto load-test-obj)
- (newline)
- (display ";testing inexact numbers; ")
- (newline)
- (SECTION 6 5 5)
- (test #t inexact? f3.9)
- (test #t 'inexact? (inexact? (max f3.9 4)))
- (test f4.0 'max (max f3.9 4))
- (test f4.0 'exact->inexact (exact->inexact 4))
- (test (- f4.0) round (- f4.5))
- (test (- f4.0) round (- f3.5))
- (test (- f4.0) round (- f3.9))
- (test f0.0 round f0.0)
- (test f0.0 round f.25)
- (test f1.0 round f0.8)
- (test f4.0 round f3.5)
- (test f4.0 round f4.5)
- (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
- (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
- (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
- (test #t call-with-output-file
- "tmp3"
- (lambda (test-file)
- (write-char #\; test-file)
- (display write-test-obj test-file)
- (newline test-file)
- (write load-test-obj test-file)
- (output-port? test-file)))
- (check-test-file "tmp3")
- (set! write-test-obj wto)
- (set! display-test-obj dto)
- (set! load-test-obj lto)
- (let ((x (string->number "4195835.0"))
- (y (string->number "3145727.0")))
- (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
- (report-errs))
-
-(define (test-bignum)
- (define tb
- (lambda (n1 n2)
- (= n1 (+ (* n2 (quotient n1 n2))
- (remainder n1 n2)))))
- (newline)
- (display ";testing bignums; ")
- (newline)
- (SECTION 6 5 5)
- (test 0 modulo -2177452800 86400)
- (test 0 modulo 2177452800 -86400)
- (test 0 modulo 2177452800 86400)
- (test 0 modulo -2177452800 -86400)
- (test #t 'remainder (tb 281474976710655 65535))
- (test #t 'remainder (tb 281474976710654 65535))
- (SECTION 6 5 6)
- (test 281474976710655 string->number "281474976710655")
- (test "281474976710655" number->string 281474976710655)
- (report-errs))
-
-(SECTION 6 5 6)
-(test "0" number->string 0)
-(test "100" number->string 100)
-(test "100" number->string 256 16)
-(test 100 string->number "100")
-(test 256 string->number "100" 16)
-(test #f string->number "")
-(test #f string->number ".")
-(test #f string->number "d")
-(test #f string->number "D")
-(test #f string->number "i")
-(test #f string->number "I")
-(test #f string->number "3i")
-(test #f string->number "3I")
-(test #f string->number "33i")
-(test #f string->number "33I")
-(test #f string->number "3.3i")
-(test #f string->number "3.3I")
-(test #f string->number "-")
-(test #f string->number "+")
-
-(SECTION 6 6)
-(test #t eqv? '#\ #\Space)
-(test #t eqv? #\space '#\Space)
-(test #t char? #\a)
-(test #t char? #\()
-(test #t char? #\ )
-(test #t char? '#\newline)
-
-(test #f char=? #\A #\B)
-(test #f char=? #\a #\b)
-(test #f char=? #\9 #\0)
-(test #t char=? #\A #\A)
-
-(test #t char<? #\A #\B)
-(test #t char<? #\a #\b)
-(test #f char<? #\9 #\0)
-(test #f char<? #\A #\A)
-
-(test #f char>? #\A #\B)
-(test #f char>? #\a #\b)
-(test #t char>? #\9 #\0)
-(test #f char>? #\A #\A)
-
-(test #t char<=? #\A #\B)
-(test #t char<=? #\a #\b)
-(test #f char<=? #\9 #\0)
-(test #t char<=? #\A #\A)
-
-(test #f char>=? #\A #\B)
-(test #f char>=? #\a #\b)
-(test #t char>=? #\9 #\0)
-(test #t char>=? #\A #\A)
-
-(test #f char-ci=? #\A #\B)
-(test #f char-ci=? #\a #\B)
-(test #f char-ci=? #\A #\b)
-(test #f char-ci=? #\a #\b)
-(test #f char-ci=? #\9 #\0)
-(test #t char-ci=? #\A #\A)
-(test #t char-ci=? #\A #\a)
-
-(test #t char-ci<? #\A #\B)
-(test #t char-ci<? #\a #\B)
-(test #t char-ci<? #\A #\b)
-(test #t char-ci<? #\a #\b)
-(test #f char-ci<? #\9 #\0)
-(test #f char-ci<? #\A #\A)
-(test #f char-ci<? #\A #\a)
-
-(test #f char-ci>? #\A #\B)
-(test #f char-ci>? #\a #\B)
-(test #f char-ci>? #\A #\b)
-(test #f char-ci>? #\a #\b)
-(test #t char-ci>? #\9 #\0)
-(test #f char-ci>? #\A #\A)
-(test #f char-ci>? #\A #\a)
-
-(test #t char-ci<=? #\A #\B)
-(test #t char-ci<=? #\a #\B)
-(test #t char-ci<=? #\A #\b)
-(test #t char-ci<=? #\a #\b)
-(test #f char-ci<=? #\9 #\0)
-(test #t char-ci<=? #\A #\A)
-(test #t char-ci<=? #\A #\a)
-
-(test #f char-ci>=? #\A #\B)
-(test #f char-ci>=? #\a #\B)
-(test #f char-ci>=? #\A #\b)
-(test #f char-ci>=? #\a #\b)
-(test #t char-ci>=? #\9 #\0)
-(test #t char-ci>=? #\A #\A)
-(test #t char-ci>=? #\A #\a)
-
-(test #t char-alphabetic? #\a)
-(test #t char-alphabetic? #\A)
-(test #t char-alphabetic? #\z)
-(test #t char-alphabetic? #\Z)
-(test #f char-alphabetic? #\0)
-(test #f char-alphabetic? #\9)
-(test #f char-alphabetic? #\space)
-(test #f char-alphabetic? #\;)
-
-(test #f char-numeric? #\a)
-(test #f char-numeric? #\A)
-(test #f char-numeric? #\z)
-(test #f char-numeric? #\Z)
-(test #t char-numeric? #\0)
-(test #t char-numeric? #\9)
-(test #f char-numeric? #\space)
-(test #f char-numeric? #\;)
-
-(test #f char-whitespace? #\a)
-(test #f char-whitespace? #\A)
-(test #f char-whitespace? #\z)
-(test #f char-whitespace? #\Z)
-(test #f char-whitespace? #\0)
-(test #f char-whitespace? #\9)
-(test #t char-whitespace? #\space)
-(test #f char-whitespace? #\;)
-
-(test #f char-upper-case? #\0)
-(test #f char-upper-case? #\9)
-(test #f char-upper-case? #\space)
-(test #f char-upper-case? #\;)
-
-(test #f char-lower-case? #\0)
-(test #f char-lower-case? #\9)
-(test #f char-lower-case? #\space)
-(test #f char-lower-case? #\;)
-
-(test #\. integer->char (char->integer #\.))
-(test #\A integer->char (char->integer #\A))
-(test #\a integer->char (char->integer #\a))
-(test #\A char-upcase #\A)
-(test #\A char-upcase #\a)
-(test #\a char-downcase #\A)
-(test #\a char-downcase #\a)
-(SECTION 6 7)
-(test #t string? "The word \"recursion\\\" has many meanings.")
-(test #t string? "")
-(define f (make-string 3 #\*))
-(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
-(test "abc" string #\a #\b #\c)
-(test "" string)
-(test 3 string-length "abc")
-(test #\a string-ref "abc" 0)
-(test #\c string-ref "abc" 2)
-(test 0 string-length "")
-(test "" substring "ab" 0 0)
-(test "" substring "ab" 1 1)
-(test "" substring "ab" 2 2)
-(test "a" substring "ab" 0 1)
-(test "b" substring "ab" 1 2)
-(test "ab" substring "ab" 0 2)
-(test "foobar" string-append "foo" "bar")
-(test "foo" string-append "foo")
-(test "foo" string-append "foo" "")
-(test "foo" string-append "" "foo")
-(test "" string-append)
-(test "" make-string 0)
-(test #t string=? "" "")
-(test #f string<? "" "")
-(test #f string>? "" "")
-(test #t string<=? "" "")
-(test #t string>=? "" "")
-(test #t string-ci=? "" "")
-(test #f string-ci<? "" "")
-(test #f string-ci>? "" "")
-(test #t string-ci<=? "" "")
-(test #t string-ci>=? "" "")
-
-(test #f string=? "A" "B")
-(test #f string=? "a" "b")
-(test #f string=? "9" "0")
-(test #t string=? "A" "A")
-
-(test #t string<? "A" "B")
-(test #t string<? "a" "b")
-(test #f string<? "9" "0")
-(test #f string<? "A" "A")
-
-(test #f string>? "A" "B")
-(test #f string>? "a" "b")
-(test #t string>? "9" "0")
-(test #f string>? "A" "A")
-
-(test #t string<=? "A" "B")
-(test #t string<=? "a" "b")
-(test #f string<=? "9" "0")
-(test #t string<=? "A" "A")
-
-(test #f string>=? "A" "B")
-(test #f string>=? "a" "b")
-(test #t string>=? "9" "0")
-(test #t string>=? "A" "A")
-
-(test #f string-ci=? "A" "B")
-(test #f string-ci=? "a" "B")
-(test #f string-ci=? "A" "b")
-(test #f string-ci=? "a" "b")
-(test #f string-ci=? "9" "0")
-(test #t string-ci=? "A" "A")
-(test #t string-ci=? "A" "a")
-
-(test #t string-ci<? "A" "B")
-(test #t string-ci<? "a" "B")
-(test #t string-ci<? "A" "b")
-(test #t string-ci<? "a" "b")
-(test #f string-ci<? "9" "0")
-(test #f string-ci<? "A" "A")
-(test #f string-ci<? "A" "a")
-
-(test #f string-ci>? "A" "B")
-(test #f string-ci>? "a" "B")
-(test #f string-ci>? "A" "b")
-(test #f string-ci>? "a" "b")
-(test #t string-ci>? "9" "0")
-(test #f string-ci>? "A" "A")
-(test #f string-ci>? "A" "a")
-
-(test #t string-ci<=? "A" "B")
-(test #t string-ci<=? "a" "B")
-(test #t string-ci<=? "A" "b")
-(test #t string-ci<=? "a" "b")
-(test #f string-ci<=? "9" "0")
-(test #t string-ci<=? "A" "A")
-(test #t string-ci<=? "A" "a")
-
-(test #f string-ci>=? "A" "B")
-(test #f string-ci>=? "a" "B")
-(test #f string-ci>=? "A" "b")
-(test #f string-ci>=? "a" "b")
-(test #t string-ci>=? "9" "0")
-(test #t string-ci>=? "A" "A")
-(test #t string-ci>=? "A" "a")
-(SECTION 6 8)
-(test #t vector? '#(0 (2 2 2 2) "Anna"))
-(test #t vector? '#())
-(test '#(a b c) vector 'a 'b 'c)
-(test '#() vector)
-(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
-(test 0 vector-length '#())
-(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
-(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
- (let ((vec (vector 0 '(2 2 2 2) "Anna")))
- (vector-set! vec 1 '("Sue" "Sue"))
- vec))
-(test '#(hi hi) make-vector 2 'hi)
-(test '#() make-vector 0)
-(test '#() make-vector 0 'a)
-(SECTION 6 9)
-(test #t procedure? car)
-(test #f procedure? 'car)
-(test #t procedure? (lambda (x) (* x x)))
-(test #f procedure? '(lambda (x) (* x x)))
-(test #t call-with-current-continuation procedure?)
-(test 7 apply + (list 3 4))
-(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
-(test 17 apply + 10 (list 3 4))
-(test '() apply list '())
-(define compose (lambda (f g) (lambda args (f (apply g args)))))
-(test 30 (compose sqt *) 12 75)
-
-(test '(b e h) map cadr '((a b) (d e) (g h)))
-(test '(5 7 9) map + '(1 2 3) '(4 5 6))
-(test '#(0 1 4 9 16) 'for-each
- (let ((v (make-vector 5)))
- (for-each (lambda (i) (vector-set! v i (* i i)))
- '(0 1 2 3 4))
- v))
-(test -3 call-with-current-continuation
- (lambda (exit)
- (for-each (lambda (x) (if (negative? x) (exit x)))
- '(54 0 37 -3 245 19))
- #t))
-(define list-length
- (lambda (obj)
- (call-with-current-continuation
- (lambda (return)
- (letrec ((r (lambda (obj) (cond ((null? obj) 0)
- ((pair? obj) (+ (r (cdr obj)) 1))
- (else (return #f))))))
- (r obj))))))
-(test 4 list-length '(1 2 3 4))
-(test #f list-length '(a b . c))
-(test '() map cadr '())
-
-;;; This tests full conformance of call-with-current-continuation. It
-;;; is a separate test because some schemes do not support call/cc
-;;; other than escape procedures. I am indebted to
-;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
-;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
-;;; trees constructed of conses.
-(define (next-leaf-generator obj eot)
- (letrec ((return #f)
- (cont (lambda (x)
- (recur obj)
- (set! cont (lambda (x) (return eot)))
- (cont #f)))
- (recur (lambda (obj)
- (if (pair? obj)
- (for-each recur obj)
- (call-with-current-continuation
- (lambda (c)
- (set! cont c)
- (return obj)))))))
- (lambda () (call-with-current-continuation
- (lambda (ret) (set! return ret) (cont #f))))))
-(define (leaf-eq? x y)
- (let* ((eot (list 'eot))
- (xf (next-leaf-generator x eot))
- (yf (next-leaf-generator y eot)))
- (letrec ((loop (lambda (x y)
- (cond ((not (eq? x y)) #f)
- ((eq? eot x) #t)
- (else (loop (xf) (yf)))))))
- (loop (xf) (yf)))))
-(define (test-cont)
- (newline)
- (display ";testing continuations; ")
- (newline)
- (SECTION 6 9)
- (test #t leaf-eq? '(a (b (c))) '((a) b c))
- (test #f leaf-eq? '(a (b (c))) '((a) b c d))
- (report-errs))
-
-;;; Test Optional R4RS DELAY syntax and FORCE procedure
-(define (test-delay)
- (newline)
- (display ";testing DELAY and FORCE; ")
- (newline)
- (SECTION 6 9)
- (test 3 'delay (force (delay (+ 1 2))))
- (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
- (list (force p) (force p))))
- (test 2 'delay (letrec ((a-stream
- (letrec ((next (lambda (n)
- (cons n (delay (next (+ n 1)))))))
- (next 0)))
- (head car)
- (tail (lambda (stream) (force (cdr stream)))))
- (head (tail (tail a-stream)))))
- (letrec ((count 0)
- (p (delay (begin (set! count (+ count 1))
- (if (> count x)
- count
- (force p)))))
- (x 5))
- (test 6 force p)
- (set! x 10)
- (test 6 force p))
- (test 3 'force
- (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
- (c #f))
- (force p)))
- (report-errs))
-
-(SECTION 6 10 1)
-(test #t input-port? (current-input-port))
-(test #t output-port? (current-output-port))
-(test #t call-with-input-file "test.scm" input-port?)
-(define this-file (open-input-file "test.scm"))
-(test #t input-port? this-file)
-(SECTION 6 10 2)
-(test #\; peek-char this-file)
-(test #\; read-char this-file)
-(test '(define cur-section '()) read this-file)
-(test #\( peek-char this-file)
-(test '(define errs '()) read this-file)
-(close-input-port this-file)
-(close-input-port this-file)
-(define (check-test-file name)
- (define test-file (open-input-file name))
- (test #t 'input-port?
- (call-with-input-file
- name
- (lambda (test-file)
- (test load-test-obj read test-file)
- (test #t eof-object? (peek-char test-file))
- (test #t eof-object? (read-char test-file))
- (input-port? test-file))))
- (test #\; read-char test-file)
- (test display-test-obj read test-file)
- (test load-test-obj read test-file)
- (close-input-port test-file))
-(SECTION 6 10 3)
-(define write-test-obj
- '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
-(define display-test-obj
- '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
-(define load-test-obj
- (list 'define 'foo (list 'quote write-test-obj)))
-(test #t call-with-output-file
- "tmp1"
- (lambda (test-file)
- (write-char #\; test-file)
- (display write-test-obj test-file)
- (newline test-file)
- (write load-test-obj test-file)
- (output-port? test-file)))
-(check-test-file "tmp1")
-
-(define test-file (open-output-file "tmp2"))
-(write-char #\; test-file)
-(display write-test-obj test-file)
-(newline test-file)
-(write load-test-obj test-file)
-(test #t output-port? test-file)
-(close-output-port test-file)
-(check-test-file "tmp2")
-(define (test-sc4)
- (newline)
- (display ";testing scheme 4 functions; ")
- (newline)
- (SECTION 6 7)
- (test '(#\P #\space #\l) string->list "P l")
- (test '() string->list "")
- (test "1\\\"" list->string '(#\1 #\\ #\"))
- (test "" list->string '())
- (SECTION 6 8)
- (test '(dah dah didah) vector->list '#(dah dah didah))
- (test '() vector->list '#())
- (test '#(dididit dah) list->vector '(dididit dah))
- (test '#() list->vector '())
- (SECTION 6 10 4)
- (load "tmp1")
- (test write-test-obj 'load foo)
- (report-errs))
-
-(report-errs)
-(if (and (string->number "0.0") (inexact? (string->number "0.0")))
- (test-inexact))
-
-(let ((n (string->number "281474976710655")))
- (if (and n (exact? n))
- (test-bignum)))
-(newline)
-(test-cont)
-(newline)
-(test-sc4)
-(newline)
-(test-delay)
-(newline)
-"last item in file"
diff --git a/ice-9/threads.scm b/ice-9/threads.scm
deleted file mode 100644
index bec189009..000000000
--- a/ice-9/threads.scm
+++ /dev/null
@@ -1,53 +0,0 @@
-;;;; Copyright (C) 1996 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-;;;;
-;;;; ----------------------------------------------------------------
-;;;; threads.scm -- User-level interface to Guile's thread system
-;;;; 4 March 1996, Anthony Green <green@cygnus.com>
-;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se>
-;;;; ----------------------------------------------------------------
-;;;;
-
-
-(define-module #/ice-9/threads)
-
-
-
-; --- MACROS -------------------------------------------------------
-
-(defmacro-public make-thread (fn . args)
- `(call-with-new-thread
- (lambda ()
- (,fn ,@args))
- (lambda args args)))
-
-(defmacro-public begin-thread (first . thunk)
- `(call-with-new-thread
- (lambda ()
- (begin
- ,first ,@thunk))
- (lambda args args)))
-
-(defmacro-public with-mutex (m . thunk)
- `(dynamic-wind
- (lambda () (lock-mutex ,m))
- (lambda () (begin ,@thunk))
- (lambda () (unlock-mutex ,m))))
-
-(defmacro-public monitor (first . thunk)
- `(with-mutex ,(make-mutex)
- (begin
- ,first ,@thunk)))