diff options
Diffstat (limited to 'ice-9')
-rw-r--r-- | ice-9/.cvsignore | 3 | ||||
-rw-r--r-- | ice-9/COPYING | 339 | ||||
-rw-r--r-- | ice-9/ChangeLog | 463 | ||||
-rw-r--r-- | ice-9/Makefile.am | 10 | ||||
-rw-r--r-- | ice-9/Makefile.in | 207 | ||||
-rw-r--r-- | ice-9/aclocal.m4 | 64 | ||||
-rw-r--r-- | ice-9/boot-9.scm | 3479 | ||||
-rwxr-xr-x | ice-9/configure | 961 | ||||
-rw-r--r-- | ice-9/configure.in | 7 | ||||
-rw-r--r-- | ice-9/debug.scm | 120 | ||||
-rw-r--r-- | ice-9/expect.scm | 125 | ||||
-rw-r--r-- | ice-9/hcons.scm | 76 | ||||
-rw-r--r-- | ice-9/lineio.scm | 112 | ||||
-rw-r--r-- | ice-9/mapping.scm | 121 | ||||
-rw-r--r-- | ice-9/poe.scm | 117 | ||||
-rw-r--r-- | ice-9/r4rs.scm | 149 | ||||
-rw-r--r-- | ice-9/slib.scm | 188 | ||||
-rw-r--r-- | ice-9/tags.scm | 23 | ||||
-rw-r--r-- | ice-9/test.scm | 1032 | ||||
-rw-r--r-- | ice-9/threads.scm | 53 |
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))) |